API tools faq
paste
Advertisement
zbyna

Untitled

zbyna
Feb 1st, 2014
199
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Pascal 179.91 KB | None | 0 0
raw download clone embed print report
  1. (*
  2.  *                         Super Object Toolkit
  3.  *
  4.  * Usage allowed under the restrictions of the Lesser GNU General Public License
  5.  * or alternatively the restrictions of the Mozilla Public License 1.1
  6.  *
  7.  * Software distributed under the License is distributed on an "AS IS" basis,
  8.  * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  9.  * the specific language governing rights and limitations under the License.
  10.  *
  11.  * Unit owner : Henri Gourvest <hgourvest@gmail.com>
  12.  * Web site   : http://www.progdigy.com
  13.  *
  14.  * This unit is inspired from the json c lib:
  15.  *   Michael Clark <michael@metaparadigm.com>
  16.  *   http://oss.metaparadigm.com/json-c/
  17.  *
  18.  *  CHANGES:
  19.  *  v1.2
  20.  *   + support of currency data type
  21.  *   + right trim unquoted string
  22.  *   + read Unicode Files and streams (Litle Endian with BOM)
  23.  *   + Fix bug on javadate functions + windows nt compatibility
  24.  *   + Now you can force to parse only the canonical syntax of JSON using the stric parameter
  25.  *   + Delphi 2010 RTTI marshalling
  26.  *  v1.1
  27.  *   + Double licence MPL or LGPL.
  28.  *   + Delphi 2009 compatibility & Unicode support.
  29.  *   + AsString return a string instead of PChar.
  30.  *   + Escaped and Unascaped JSON serialiser.
  31.  *   + Missed FormFeed added \f
  32.  *   - Removed @ trick, uses forcepath() method instead.
  33.  *   + Fixed parse error with uppercase E symbol in numbers.
  34.  *   + Fixed possible buffer overflow when enlarging array.
  35.  *   + Added "delete", "pack", "insert" methods for arrays and/or objects
  36.  *   + Multi parametters when calling methods
  37.  *   + Delphi Enumerator (for obj1 in obj2 do ...)
  38.  *   + Format method ex: obj.format('<%name%>%tab[1]%</%name%>')
  39.  *   + ParseFile and ParseStream methods
  40.  *   + Parser now understand hexdecimal c syntax ex: \xFF
  41.  *   + Null Object Design Patern (ex: for obj in values.N['path'] do ...)
  42.  *  v1.0
  43.  *   + renamed class
  44.  *   + interfaced object
  45.  *   + added a new data type: the method
  46.  *   + parser can now evaluate properties and call methods
  47.  *   - removed obselet rpc class
  48.  *   - removed "find" method, now you can use "parse" method instead
  49.  *  v0.6
  50.  *   + refactoring
  51.  *  v0.5
  52.  *   + new find method to get or set value using a path syntax
  53.  *       ex: obj.s['obj.prop[1]'] := 'string value';
  54.  *           obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary
  55.  *  v0.4
  56.  *   + bug corrected: AVL tree badly balanced.
  57.  *  v0.3
  58.  *   + New validator partially based on the Kwalify syntax.
  59.  *   + extended syntax to parse unquoted fields.
  60.  *   + Freepascal compatibility win32/64 Linux32/64.
  61.  *   + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC.
  62.  *   + new TJsonObject.Compare function.
  63.  *  v0.2
  64.  *   + Hashed string list replaced with a faster AVL tree
  65.  *   + JsonInt data type can be changed to int64
  66.  *   + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions
  67.  *   + from json-c v0.7
  68.  *     + Add escaping of backslash to json output
  69.  *     + Add escaping of foward slash on tokenizing and output
  70.  *     + Changes to internal tokenizer from using recursion to
  71.  *       using a depth state structure to allow incremental parsing
  72.  *  v0.1
  73.  *   + first release
  74.  *)
  75.  
  76. {$IFDEF FPC}
  77.   {$MODE OBJFPC}{$H+}
  78. {$ENDIF}
  79.  
  80. {$DEFINE SUPER_METHOD}
  81. {$DEFINE WINDOWSNT_COMPATIBILITY}
  82. {.$DEFINE DEBUG} // track memory leack
  83.  
  84. unit superobject;
  85.  
  86. interface
  87. uses
  88.   Classes
  89. {$IFDEF VER210}
  90.   ,Generics.Collections, RTTI, TypInfo
  91. {$ENDIF}
  92.   ;
  93.  
  94. type
  95. {$IFNDEF FPC}
  96.   PtrInt = longint;
  97.   PtrUInt = Longword;
  98. {$ENDIF}
  99.   SuperInt = Int64;
  100.  
  101. {$if (sizeof(Char) = 1)}
  102.   SOChar = WideChar;
  103.   SOIChar = Word;
  104.   PSOChar = PWideChar;
  105.   SOString = WideString;
  106. {$else}
  107.   SOChar = Char;
  108.   SOIChar = Word;
  109.   PSOChar = PChar;
  110.   SOString = string;
  111. {$ifend}
  112.  
  113. const
  114.   SUPER_ARRAY_LIST_DEFAULT_SIZE = 32;
  115.   SUPER_TOKENER_MAX_DEPTH = 32;
  116.  
  117.   SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8;
  118.   SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1);
  119.  
  120. type
  121.   // forward declarations
  122.   TSuperObject = class;
  123.   ISuperObject = interface;
  124.   TSuperArray = class;
  125.  
  126. (* AVL Tree
  127.  *  This is a "special" autobalanced AVL tree
  128.  *  It use a hash value for fast compare
  129.  *)
  130.  
  131. {$IFDEF SUPER_METHOD}
  132.   TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject);
  133. {$ENDIF}
  134.  
  135.  
  136.   TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1;
  137.  
  138.   TSuperAvlSearchType = (stEQual, stLess, stGreater);
  139.   TSuperAvlSearchTypes = set of TSuperAvlSearchType;
  140.   TSuperAvlIterator = class;
  141.  
  142.   TSuperAvlEntry = class
  143.   private
  144.     FGt, FLt: TSuperAvlEntry;
  145.     FBf: integer;
  146.     FHash: Cardinal;
  147.     FName: SOString;
  148.     FPtr: Pointer;
  149.     function GetValue: ISuperObject;
  150.     procedure SetValue(const val: ISuperObject);
  151.   public
  152.     class function Hash(const k: SOString): Cardinal; virtual;
  153.     constructor Create(const AName: SOString; Obj: Pointer); virtual;
  154.     property Name: SOString read FName;
  155.     property Ptr: Pointer read FPtr;
  156.     property Value: ISuperObject read GetValue write SetValue;
  157.   end;
  158.  
  159.   TSuperAvlTree = class
  160.   private
  161.     FRoot: TSuperAvlEntry;
  162.     FCount: Integer;
  163.     function balance(bal: TSuperAvlEntry): TSuperAvlEntry;
  164.   protected
  165.     procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual;
  166.     function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual;
  167.     function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual;
  168.     function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual;
  169.     function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual;
  170.   public
  171.     constructor Create; virtual;
  172.     destructor Destroy; override;
  173.     function IsEmpty: boolean;
  174.     procedure Clear(all: boolean = false); virtual;
  175.     procedure Pack(all: boolean);
  176.     function Delete(const k: SOString): ISuperObject;
  177.     function GetEnumerator: TSuperAvlIterator;
  178.     property count: Integer read FCount;
  179.   end;
  180.  
  181.   TSuperTableString = class(TSuperAvlTree)
  182.   protected
  183.     procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override;
  184.     procedure PutO(const k: SOString; const value: ISuperObject);
  185.     function GetO(const k: SOString): ISuperObject;
  186.     procedure PutS(const k: SOString; const value: SOString);
  187.     function GetS(const k: SOString): SOString;
  188.     procedure PutI(const k: SOString; value: SuperInt);
  189.     function GetI(const k: SOString): SuperInt;
  190.     procedure PutD(const k: SOString; value: Double);
  191.     function GetD(const k: SOString): Double;
  192.     procedure PutB(const k: SOString; value: Boolean);
  193.     function GetB(const k: SOString): Boolean;
  194. {$IFDEF SUPER_METHOD}
  195.     procedure PutM(const k: SOString; value: TSuperMethod);
  196.     function GetM(const k: SOString): TSuperMethod;
  197. {$ENDIF}
  198.     procedure PutN(const k: SOString; const value: ISuperObject);
  199.     function GetN(const k: SOString): ISuperObject;
  200.     procedure PutC(const k: SOString; value: Currency);
  201.     function GetC(const k: SOString): Currency;
  202.   public
  203.     property O[const k: SOString]: ISuperObject read GetO write PutO; default;
  204.     property S[const k: SOString]: SOString read GetS write PutS;
  205.     property I[const k: SOString]: SuperInt read GetI write PutI;
  206.     property D[const k: SOString]: Double read GetD write PutD;
  207.     property B[const k: SOString]: Boolean read GetB write PutB;
  208. {$IFDEF SUPER_METHOD}
  209.     property M[const k: SOString]: TSuperMethod read GetM write PutM;
  210. {$ENDIF}
  211.     property N[const k: SOString]: ISuperObject read GetN write PutN;
  212.     property C[const k: SOString]: Currency read GetC write PutC;
  213.  
  214.     function GetValues: ISuperObject;
  215.     function GetNames: ISuperObject;
  216.   end;
  217.  
  218.   TSuperAvlIterator = class
  219.   private
  220.     FTree: TSuperAvlTree;
  221.     FBranch: TSuperAvlBitArray;
  222.     FDepth: LongInt;
  223.     FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry;
  224.   public
  225.     constructor Create(tree: TSuperAvlTree); virtual;
  226.     procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]);
  227.     procedure First;
  228.     procedure Last;
  229.     function GetIter: TSuperAvlEntry;
  230.     procedure Next;
  231.     procedure Prior;
  232.     // delphi enumerator
  233.     function MoveNext: Boolean;
  234.     property Current: TSuperAvlEntry read GetIter;
  235.   end;
  236.  
  237.   TSuperObjectArray = array[0..(high(PtrInt) div sizeof(TSuperObject))-1] of ISuperObject;
  238.   PSuperObjectArray = ^TSuperObjectArray;
  239.  
  240.   TSuperArray = class
  241.   private
  242.     FArray: PSuperObjectArray;
  243.     FLength: Integer;
  244.     FSize: Integer;
  245.     procedure Expand(max: Integer);
  246.   protected
  247.     function GetO(const index: integer): ISuperObject;
  248.     procedure PutO(const index: integer; const Value: ISuperObject);
  249.     function GetB(const index: integer): Boolean;
  250.     procedure PutB(const index: integer; Value: Boolean);
  251.     function GetI(const index: integer): SuperInt;
  252.     procedure PutI(const index: integer; Value: SuperInt);
  253.     function GetD(const index: integer): Double;
  254.     procedure PutD(const index: integer; Value: Double);
  255.     function GetC(const index: integer): Currency;
  256.     procedure PutC(const index: integer; Value: Currency);
  257.     function GetS(const index: integer): SOString;
  258.     procedure PutS(const index: integer; const Value: SOString);
  259. {$IFDEF SUPER_METHOD}
  260.     function GetM(const index: integer): TSuperMethod;
  261.     procedure PutM(const index: integer; Value: TSuperMethod);
  262. {$ENDIF}
  263.     function GetN(const index: integer): ISuperObject;
  264.     procedure PutN(const index: integer; const Value: ISuperObject);
  265.   public
  266.     constructor Create; virtual;
  267.     destructor Destroy; override;
  268.     function Add(const Data: ISuperObject): Integer;
  269.     function Delete(index: Integer): ISuperObject;
  270.     procedure Insert(index: Integer; const value: ISuperObject);
  271.     procedure Clear(all: boolean = false);
  272.     procedure Pack(all: boolean);
  273.     property Length: Integer read FLength;
  274.  
  275.     property N[const index: integer]: ISuperObject read GetN write PutN;
  276.     property O[const index: integer]: ISuperObject read GetO write PutO; default;
  277.     property B[const index: integer]: boolean read GetB write PutB;
  278.     property I[const index: integer]: SuperInt read GetI write PutI;
  279.     property D[const index: integer]: Double read GetD write PutD;
  280.     property C[const index: integer]: Currency read GetC write PutC;
  281.     property S[const index: integer]: SOString read GetS write PutS;
  282. {$IFDEF SUPER_METHOD}
  283.     property M[const index: integer]: TSuperMethod read GetM write PutM;
  284. {$ENDIF}
  285. //    property A[const index: integer]: TSuperArray read GetA;
  286.   end;
  287.  
  288.   TSuperWriter = class
  289.   public
  290.     // abstact methods to overide
  291.     function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract;
  292.     function Append(buf: PSOChar): Integer; overload; virtual; abstract;
  293.     procedure Reset; virtual; abstract;
  294.   end;
  295.  
  296.   TSuperWriterString = class(TSuperWriter)
  297.   private
  298.     FBuf: PSOChar;
  299.     FBPos: integer;
  300.     FSize: integer;
  301.   public
  302.     function Append(buf: PSOChar; Size: Integer): Integer; overload; override;
  303.     function Append(buf: PSOChar): Integer; overload; override;
  304.     procedure Reset; override;
  305.     procedure TrimRight;
  306.     constructor Create; virtual;
  307.     destructor Destroy; override;
  308.     function GetString: SOString;
  309.     property Data: PSOChar read FBuf;
  310.     property Size: Integer read FSize;
  311.     property Position: integer read FBPos;
  312.   end;
  313.  
  314.   TSuperWriterStream = class(TSuperWriter)
  315.   private
  316.     FStream: TStream;
  317.   public
  318.     function Append(buf: PSOChar): Integer; override;
  319.     procedure Reset; override;
  320.     constructor Create(AStream: TStream); reintroduce; virtual;
  321.   end;
  322.  
  323.   TSuperAnsiWriterStream = class(TSuperWriterStream)
  324.   public
  325.     function Append(buf: PSOChar; Size: Integer): Integer; override;
  326.   end;
  327.  
  328.   TSuperUnicodeWriterStream = class(TSuperWriterStream)
  329.   public
  330.     function Append(buf: PSOChar; Size: Integer): Integer; override;
  331.   end;
  332.  
  333.   TSuperWriterFake = class(TSuperWriter)
  334.   private
  335.     FSize: Integer;
  336.   public
  337.     function Append(buf: PSOChar; Size: Integer): Integer; override;
  338.     function Append(buf: PSOChar): Integer; override;
  339.     procedure Reset; override;
  340.     constructor Create; reintroduce; virtual;
  341.     property size: integer read FSize;
  342.   end;
  343.  
  344.   TSuperWriterSock = class(TSuperWriter)
  345.   private
  346.     FSocket: longint;
  347.     FSize: Integer;
  348.   public
  349.     function Append(buf: PSOChar; Size: Integer): Integer; override;
  350.     function Append(buf: PSOChar): Integer; override;
  351.     procedure Reset; override;
  352.     constructor Create(ASocket: longint); reintroduce; virtual;
  353.     property Socket: longint read FSocket;
  354.     property Size: Integer read FSize;
  355.   end;
  356.  
  357.   TSuperTokenizerError = (
  358.     teSuccess,
  359.     teContinue,
  360.     teDepth,
  361.     teParseEof,
  362.     teParseUnexpected,
  363.     teParseNull,
  364.     teParseBoolean,
  365.     teParseNumber,
  366.     teParseArray,
  367.     teParseObjectKeyName,
  368.     teParseObjectKeySep,
  369.     teParseObjectValueSep,
  370.     teParseString,
  371.     teParseComment,
  372.     teEvalObject,
  373.     teEvalArray,
  374.     teEvalMethod,
  375.     teEvalInt
  376.   );
  377.  
  378.   TSuperTokenerState = (
  379.     tsEatws,
  380.     tsStart,
  381.     tsFinish,
  382.     tsNull,
  383.     tsCommentStart,
  384.     tsComment,
  385.     tsCommentEol,
  386.     tsCommentEnd,
  387.     tsString,
  388.     tsStringEscape,
  389.     tsIdentifier,
  390.     tsEscapeUnicode,
  391.     tsEscapeHexadecimal,
  392.     tsBoolean,
  393.     tsNumber,
  394.     tsArray,
  395.     tsArrayAdd,
  396.     tsArraySep,
  397.     tsObjectFieldStart,
  398.     tsObjectField,
  399.     tsObjectUnquotedField,
  400.     tsObjectFieldEnd,
  401.     tsObjectValue,
  402.     tsObjectValueAdd,
  403.     tsObjectSep,
  404.     tsEvalProperty,
  405.     tsEvalArray,
  406.     tsEvalMethod,
  407.     tsParamValue,
  408.     tsParamPut,
  409.     tsMethodValue,
  410.     tsMethodPut
  411.   );
  412.  
  413.   PSuperTokenerSrec = ^TSuperTokenerSrec;
  414.   TSuperTokenerSrec = record
  415.     state, saved_state: TSuperTokenerState;
  416.     obj: ISuperObject;
  417.     current: ISuperObject;
  418.     field_name: SOString;
  419.     parent: ISuperObject;
  420.     gparent: ISuperObject;
  421.   end;
  422.  
  423.   TSuperTokenizer = class
  424.   public
  425.     str: PSOChar;
  426.     pb: TSuperWriterString;
  427.     depth, is_double, floatcount, st_pos, char_offset: Integer;
  428.     err:  TSuperTokenizerError;
  429.     ucs_char: Word;
  430.     quote_char: SOChar;
  431.     stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec;
  432.     line, col: Integer;
  433.   public
  434.     constructor Create; virtual;
  435.     destructor Destroy; override;
  436.     procedure ResetLevel(adepth: integer);
  437.     procedure Reset;
  438.   end;
  439.  
  440.   // supported object types
  441.   TSuperType = (
  442.     stNull,
  443.     stBoolean,
  444.     stDouble,
  445.     stCurrency,
  446.     stInt,
  447.     stObject,
  448.     stArray,
  449.     stString
  450. {$IFDEF SUPER_METHOD}
  451.     ,stMethod
  452. {$ENDIF}
  453.   );
  454.  
  455.   TSuperValidateError = (
  456.     veRuleMalformated,
  457.     veFieldIsRequired,
  458.     veInvalidDataType,
  459.     veFieldNotFound,
  460.     veUnexpectedField,
  461.     veDuplicateEntry,
  462.     veValueNotInEnum,
  463.     veInvalidLength,
  464.     veInvalidRange
  465.   );
  466.  
  467.   TSuperFindOption = (
  468.     foCreatePath,
  469.     foPutValue,
  470.     foDelete
  471. {$IFDEF SUPER_METHOD}
  472.     ,foCallMethod
  473. {$ENDIF}
  474.   );
  475.  
  476.   TSuperFindOptions = set of TSuperFindOption;
  477.   TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError);
  478.   TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString);
  479.  
  480.   TSuperEnumerator = class
  481.   private
  482.     FObj: ISuperObject;
  483.     FObjEnum: TSuperAvlIterator;
  484.     FCount: Integer;
  485.   public
  486.     constructor Create(const obj: ISuperObject); virtual;
  487.     destructor Destroy; override;
  488.     function MoveNext: Boolean;
  489.     function GetCurrent: ISuperObject;
  490.     property Current: ISuperObject read GetCurrent;
  491.   end;
  492.  
  493.   ISuperObject = interface
  494.   ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}']
  495.     function GetEnumerator: TSuperEnumerator;
  496.     function GetDataType: TSuperType;
  497.     function GetProcessing: boolean;
  498.     procedure SetProcessing(value: boolean);
  499.     function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
  500.     function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
  501.  
  502.     function GetO(const path: SOString): ISuperObject;
  503.     procedure PutO(const path: SOString; const Value: ISuperObject);
  504.     function GetB(const path: SOString): Boolean;
  505.     procedure PutB(const path: SOString; Value: Boolean);
  506.     function GetI(const path: SOString): SuperInt;
  507.     procedure PutI(const path: SOString; Value: SuperInt);
  508.     function GetD(const path: SOString): Double;
  509.     procedure PutC(const path: SOString; Value: Currency);
  510.     function GetC(const path: SOString): Currency;
  511.     procedure PutD(const path: SOString; Value: Double);
  512.     function GetS(const path: SOString): SOString;
  513.     procedure PutS(const path: SOString; const Value: SOString);
  514. {$IFDEF SUPER_METHOD}
  515.     function GetM(const path: SOString): TSuperMethod;
  516.     procedure PutM(const path: SOString; Value: TSuperMethod);
  517. {$ENDIF}
  518.     function GetA(const path: SOString): TSuperArray;
  519.  
  520.     // Null Object Design patern
  521.     function GetN(const path: SOString): ISuperObject;
  522.     procedure PutN(const path: SOString; const Value: ISuperObject);
  523.  
  524.     // Writers
  525.     function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
  526.     function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
  527.     function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
  528.     function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
  529.     function CalcSize(indent: boolean = false; escape: boolean = true): integer;
  530.  
  531.     // convert
  532.     function AsBoolean: Boolean;
  533.     function AsInteger: SuperInt;
  534.     function AsDouble: Double;
  535.     function AsCurrency: Currency;
  536.     function AsString: SOString;
  537.     function AsArray: TSuperArray;
  538.     function AsObject: TSuperTableString;
  539. {$IFDEF SUPER_METHOD}
  540.     function AsMethod: TSuperMethod;
  541. {$ENDIF}
  542.     function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
  543.  
  544.     procedure Clear(all: boolean = false);
  545.     procedure Pack(all: boolean = false);
  546.  
  547.     property N[const path: SOString]: ISuperObject read GetN write PutN;
  548.     property O[const path: SOString]: ISuperObject read GetO write PutO; default;
  549.     property B[const path: SOString]: boolean read GetB write PutB;
  550.     property I[const path: SOString]: SuperInt read GetI write PutI;
  551.     property D[const path: SOString]: Double read GetD write PutD;
  552.     property C[const path: SOString]: Currency read GetC write PutC;
  553.     property S[const path: SOString]: SOString read GetS write PutS;
  554. {$IFDEF SUPER_METHOD}
  555.     property M[const path: SOString]: TSuperMethod read GetM write PutM;
  556. {$ENDIF}
  557.     property A[const path: SOString]: TSuperArray read GetA;
  558.  
  559. {$IFDEF SUPER_METHOD}
  560.     function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload;
  561.     function call(const path, param: SOString): ISuperObject; overload;
  562. {$ENDIF}
  563.     // clone a node
  564.     function Clone: ISuperObject;
  565.     function Delete(const path: SOString): ISuperObject;
  566.     // merges tow objects of same type, if reference is true then nodes are not cloned
  567.     procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
  568.     procedure Merge(const str: SOString); overload;
  569.  
  570.     // validate methods
  571.     function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
  572.     function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
  573.  
  574.     // compare
  575.     function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
  576.     function Compare(const str: SOString): TSuperCompareResult; overload;
  577.  
  578.     // the data type
  579.     function IsType(AType: TSuperType): boolean;
  580.     property DataType: TSuperType read GetDataType;
  581.     property Processing: boolean read GetProcessing write SetProcessing;
  582.  
  583.     function GetDataPtr: Pointer;
  584.     procedure SetDataPtr(const Value: Pointer);
  585.     property DataPtr: Pointer read GetDataPtr write SetDataPtr;
  586.   end;
  587.  
  588.   TSuperObject = class(TObject, ISuperObject)
  589.   private
  590.     FRefCount: Integer;
  591.     FProcessing: boolean;
  592.     FDataType: TSuperType;
  593.     FDataPtr: Pointer;
  594. {.$if true}
  595.     FO: record
  596.       case TSuperType of
  597.         stBoolean: (c_boolean: boolean);
  598.         stDouble: (c_double: double);
  599.         stCurrency: (c_currency: Currency);
  600.         stInt: (c_int: SuperInt);
  601.         stObject: (c_object: TSuperTableString);
  602.         stArray: (c_array: TSuperArray);
  603. {$IFDEF SUPER_METHOD}
  604.         stMethod: (c_method: TSuperMethod);
  605. {$ENDIF}
  606.       end;
  607. {.$ifend}
  608.     FOString: SOString;
  609.     function GetDataType: TSuperType;
  610.     function GetDataPtr: Pointer;
  611.     procedure SetDataPtr(const Value: Pointer);
  612.   protected
  613.     function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};virtual;
  614.     function _AddRef: Integer; virtual; stdcall;
  615.     function _Release: Integer; virtual; stdcall;
  616.  
  617.     function GetO(const path: SOString): ISuperObject;
  618.     procedure PutO(const path: SOString; const Value: ISuperObject);
  619.     function GetB(const path: SOString): Boolean;
  620.     procedure PutB(const path: SOString; Value: Boolean);
  621.     function GetI(const path: SOString): SuperInt;
  622.     procedure PutI(const path: SOString; Value: SuperInt);
  623.     function GetD(const path: SOString): Double;
  624.     procedure PutD(const path: SOString; Value: Double);
  625.     procedure PutC(const path: SOString; Value: Currency);
  626.     function GetC(const path: SOString): Currency;
  627.     function GetS(const path: SOString): SOString;
  628.     procedure PutS(const path: SOString; const Value: SOString);
  629. {$IFDEF SUPER_METHOD}
  630.     function GetM(const path: SOString): TSuperMethod;
  631.     procedure PutM(const path: SOString; Value: TSuperMethod);
  632. {$ENDIF}
  633.     function GetA(const path: SOString): TSuperArray;
  634.     function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual;
  635.   public
  636.     function GetEnumerator: TSuperEnumerator;
  637.     procedure AfterConstruction; override;
  638.     procedure BeforeDestruction; override;
  639.     class function NewInstance: TObject; override;
  640.     property RefCount: Integer read FRefCount;
  641.  
  642.     function GetProcessing: boolean;
  643.     procedure SetProcessing(value: boolean);
  644.  
  645.     // Writers
  646.     function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
  647.     function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
  648.     function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
  649.     function CalcSize(indent: boolean = false; escape: boolean = true): integer;
  650.     function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
  651.  
  652.     // parser  ... owned!
  653.     class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
  654.        const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
  655.     class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
  656.        const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
  657.     class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
  658.        const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
  659.     class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil;
  660.       options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
  661.  
  662.     // constructors / destructor
  663.     constructor Create(jt: TSuperType = stObject); overload; virtual;
  664.     constructor Create(b: boolean); overload; virtual;
  665.     constructor Create(i: SuperInt); overload; virtual;
  666.     constructor Create(d: double); overload; virtual;
  667.     constructor CreateCurrency(c: Currency); overload; virtual;
  668.     constructor Create(const s: SOString); overload; virtual;
  669. {$IFDEF SUPER_METHOD}
  670.     constructor Create(m: TSuperMethod); overload; virtual;
  671. {$ENDIF}
  672.     destructor Destroy; override;
  673.  
  674.     // convert
  675.     function AsBoolean: Boolean; virtual;
  676.     function AsInteger: SuperInt; virtual;
  677.     function AsDouble: Double; virtual;
  678.     function AsCurrency: Currency; virtual;
  679.     function AsString: SOString; virtual;
  680.     function AsArray: TSuperArray; virtual;
  681.     function AsObject: TSuperTableString; virtual;
  682. {$IFDEF SUPER_METHOD}
  683.     function AsMethod: TSuperMethod; virtual;
  684. {$ENDIF}
  685.     procedure Clear(all: boolean = false); virtual;
  686.     procedure Pack(all: boolean = false); virtual;
  687.     function GetN(const path: SOString): ISuperObject;
  688.     procedure PutN(const path: SOString; const Value: ISuperObject);
  689.     function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
  690.     function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
  691.  
  692.     property N[const path: SOString]: ISuperObject read GetN write PutN;
  693.     property O[const path: SOString]: ISuperObject read GetO write PutO; default;
  694.     property B[const path: SOString]: boolean read GetB write PutB;
  695.     property I[const path: SOString]: SuperInt read GetI write PutI;
  696.     property D[const path: SOString]: Double read GetD write PutD;
  697.     property C[const path: SOString]: Currency read GetC write PutC;
  698.     property S[const path: SOString]: SOString read GetS write PutS;
  699. {$IFDEF SUPER_METHOD}
  700.     property M[const path: SOString]: TSuperMethod read GetM write PutM;
  701. {$ENDIF}
  702.     property A[const path: SOString]: TSuperArray read GetA;
  703.  
  704. {$IFDEF SUPER_METHOD}
  705.     function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual;
  706.     function call(const path, param: SOString): ISuperObject; overload; virtual;
  707. {$ENDIF}
  708.     // clone a node
  709.     function Clone: ISuperObject; virtual;
  710.     function Delete(const path: SOString): ISuperObject;
  711.     // merges tow objects of same type, if reference is true then nodes are not cloned
  712.     procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
  713.     procedure Merge(const str: SOString); overload;
  714.  
  715.     // validate methods
  716.     function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
  717.     function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
  718.  
  719.     // compare
  720.     function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
  721.     function Compare(const str: SOString): TSuperCompareResult; overload;
  722.  
  723.     // the data type
  724.     function IsType(AType: TSuperType): boolean;
  725.     property DataType: TSuperType read GetDataType;
  726.     // a data pointer to link to something ele, a treeview for example
  727.     property DataPtr: Pointer read GetDataPtr write SetDataPtr;
  728.     property Processing: boolean read GetProcessing;
  729.   end;
  730.  
  731. {$IFDEF VER210}
  732.   TSuperRttiContext = class;
  733.  
  734.   TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
  735.   TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
  736.  
  737.   TSuperAttribute = class(TCustomAttribute)
  738.   private
  739.     FName: string;
  740.   public
  741.     constructor Create(const AName: string);
  742.     property Name: string read FName;
  743.   end;
  744.  
  745.   SOName = class(TSuperAttribute);
  746.   SODefault = class(TSuperAttribute);
  747.  
  748.  
  749.   TSuperRttiContext = class
  750.   private
  751.     class function GetFieldName(r: TRttiField): string;
  752.     class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
  753.   public
  754.     Context: TRttiContext;
  755.     SerialFromJson: TDictionary<PTypeInfo, TSerialFromJson>;
  756.     SerialToJson: TDictionary<PTypeInfo, TSerialToJson>;
  757.     constructor Create; virtual;
  758.     destructor Destroy; override;
  759.     function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual;
  760.     function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual;
  761.     function AsType<T>(const obj: ISuperObject): T;
  762.     function AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject;
  763.   end;
  764.  
  765.   TSuperObjectHelper = class helper for TObject
  766.   public
  767.     function ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
  768.     constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload;
  769.     constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload;
  770.   end;
  771. {$ENDIF}
  772.  
  773.   TSuperObjectIter = record
  774.     key: SOString;
  775.     val: ISuperObject;
  776.     Ite: TSuperAvlIterator;
  777.   end;
  778.  
  779. function ObjectIsError(obj: TSuperObject): boolean;
  780. function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
  781. function ObjectGetType(const obj: ISuperObject): TSuperType;
  782.  
  783. function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
  784. function ObjectFindNext(var F: TSuperObjectIter): boolean;
  785. procedure ObjectFindClose(var F: TSuperObjectIter);
  786.  
  787. function SO(const s: SOString = '{}'): ISuperObject; overload;
  788. function SO(const value: Variant): ISuperObject; overload;
  789. function SO(const Args: array of const): ISuperObject; overload;
  790.  
  791. function SA(const Args: array of const): ISuperObject; overload;
  792.  
  793. function JavaToDelphiDateTime(const dt: int64): TDateTime;
  794. function DelphiToJavaDateTime(const dt: TDateTime): int64;
  795.  
  796. {$IFDEF VER210}
  797.  
  798. type
  799.   TSuperInvokeResult = (
  800.     irSuccess,
  801.     irMethothodError,  // method don't exist
  802.     irParamError,     // invalid parametters
  803.     irError            // other error
  804.   );
  805.  
  806. function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload;
  807. function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload;
  808. function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload;
  809. {$ENDIF}
  810.  
  811. implementation
  812. uses sysutils,
  813. {$IFDEF UNIX}
  814.   baseunix, unix, DateUtils
  815. {$ELSE}
  816.   Windows
  817. {$ENDIF}
  818. {$IFDEF FPC}
  819.   ,sockets
  820. {$ELSE}
  821.   ,WinSock
  822. {$ENDIF};
  823.  
  824. {$IFDEF DEBUG}
  825. var
  826.   debugcount: integer = 0;
  827. {$ENDIF}
  828.  
  829. const
  830.   super_number_chars_set = ['0'..'9','.','+','-','e','E'];
  831.   super_hex_chars: PSOChar = '0123456789abcdef';
  832.   super_hex_chars_set = ['0'..'9','a'..'f','A'..'F'];
  833.  
  834.   ESC_BS: PSOChar = '\b';
  835.   ESC_LF: PSOChar = '\n';
  836.   ESC_CR: PSOChar = '\r';
  837.   ESC_TAB: PSOChar = '\t';
  838.   ESC_FF: PSOChar = '\f';
  839.   ESC_QUOT: PSOChar = '\"';
  840.   ESC_SL: PSOChar = '\\';
  841.   ESC_SR: PSOChar = '\/';
  842.   ESC_ZERO: PSOChar = '\u0000';
  843.  
  844.   TOK_CRLF: PSOChar = #13#10;
  845.   TOK_SP: PSOChar = #32;
  846.   TOK_BS: PSOChar = #8;
  847.   TOK_TAB: PSOChar = #9;
  848.   TOK_LF: PSOChar = #10;
  849.   TOK_FF: PSOChar = #12;
  850.   TOK_CR: PSOChar = #13;
  851. //  TOK_SL: PSOChar = '\';
  852. //  TOK_SR: PSOChar = '/';
  853.   TOK_NULL: PSOChar = 'null';
  854.   TOK_CBL: PSOChar = '{'; // curly bracket left
  855.   TOK_CBR: PSOChar = '}'; // curly bracket right
  856.   TOK_ARL: PSOChar = '[';
  857.   TOK_ARR: PSOChar = ']';
  858.   TOK_ARRAY: PSOChar = '[]';
  859.   TOK_OBJ: PSOChar = '{}'; // empty object
  860.   TOK_COM: PSOChar = ','; // Comma
  861.   TOK_DQT: PSOChar = '"'; // Double Quote
  862.   TOK_TRUE: PSOChar = 'true';
  863.   TOK_FALSE: PSOChar = 'false';
  864.  
  865. {$if (sizeof(Char) = 1)}
  866. function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer;
  867. var
  868.   P1, P2: PWideChar;
  869.   I: Cardinal;
  870.   C1, C2: WideChar;
  871. begin
  872.   P1 := Str1;
  873.   P2 := Str2;
  874.   I := 0;
  875.   while I < MaxLen do
  876.   begin
  877.     C1 := P1^;
  878.     C2 := P2^;
  879.  
  880.     if (C1 <> C2) or (C1 = #0) then
  881.     begin
  882.       Result := Ord(C1) - Ord(C2);
  883.       Exit;
  884.     end;
  885.  
  886.     Inc(P1);
  887.     Inc(P2);
  888.     Inc(I);
  889.   end;
  890.   Result := 0;
  891. end;
  892.  
  893. function StrComp(const Str1, Str2: PSOChar): Integer;
  894. var
  895.   P1, P2: PWideChar;
  896.   C1, C2: WideChar;
  897. begin
  898.   P1 := Str1;
  899.   P2 := Str2;
  900.   while True do
  901.   begin
  902.     C1 := P1^;
  903.     C2 := P2^;
  904.  
  905.     if (C1 <> C2) or (C1 = #0) then
  906.     begin
  907.       Result := Ord(C1) - Ord(C2);
  908.       Exit;
  909.     end;
  910.  
  911.     Inc(P1);
  912.     Inc(P2);
  913.   end;
  914. end;
  915.  
  916. function StrLen(const Str: PSOChar): Cardinal;
  917. var
  918.   p: PSOChar;
  919. begin
  920.   Result := 0;
  921.   if Str <> nil then
  922.   begin
  923.     p := Str;
  924.     while p^ <> #0 do inc(p);
  925.     Result := (p - Str);
  926.   end;
  927. end;
  928. {$ifend}
  929.  
  930. function CurrToStr(c: Currency): SOString;
  931. var
  932.   p: PSOChar;
  933.   i, len: Integer;
  934. begin
  935.   Result := IntToStr(Abs(PInt64(@c)^));
  936.   len := Length(Result);
  937.   SetLength(Result, len+1);
  938.   if c <> 0 then
  939.   begin
  940.     while len <= 4 do
  941.     begin
  942.       Result := '0' + Result;
  943.       inc(len);
  944.     end;
  945.  
  946.     p := PSOChar(Result);
  947.     inc(p, len-1);
  948.     i := 0;
  949.     repeat
  950.       if p^ <> '0' then
  951.       begin
  952.         len := len - i + 1;
  953.         repeat
  954.           p[1] := p^;
  955.           dec(p);
  956.           inc(i);
  957.         until i > 3;
  958.         Break;
  959.       end;
  960.       dec(p);
  961.       inc(i);
  962.       if i > 3 then
  963.       begin
  964.         len := len - i + 1;
  965.         Break;
  966.       end;
  967.     until false;
  968.     p[1] := '.';
  969.     SetLength(Result, len);
  970.     if c < 0 then
  971.       Result := '-' + Result;
  972.   end;
  973. end;
  974.  
  975. {$IFDEF UNIX}
  976.   {$linklib c}
  977. {$ENDIF}
  978. function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl;
  979.   external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF};
  980.  
  981. {$IFDEF UNIX}
  982. type
  983.   ptm = ^tm;
  984.   tm = record
  985.     tm_sec: Integer;        (* Seconds: 0-59 (K&R says 0-61?) *)
  986.     tm_min: Integer;        (* Minutes: 0-59 *)
  987.     tm_hour: Integer;   (* Hours since midnight: 0-23 *)
  988.     tm_mday: Integer;   (* Day of the month: 1-31 *)
  989.     tm_mon: Integer;        (* Months *since* january: 0-11 *)
  990.     tm_year: Integer;   (* Years since 1900 *)
  991.     tm_wday: Integer;   (* Days since Sunday (0-6) *)
  992.     tm_yday: Integer;   (* Days since Jan. 1: 0-365 *)
  993.     tm_isdst: Integer;  (* +1 Daylight Savings Time, 0 No DST, -1 don't know *)
  994.   end;
  995.  
  996. function mktime(p: ptm): LongInt; cdecl; external;
  997. function gmtime(const t: PLongint): ptm; cdecl; external;
  998. function localtime (const t: PLongint): ptm; cdecl; external;
  999.  
  1000. function DelphiToJavaDateTime(const dt: TDateTime): Int64;
  1001. var
  1002.   p: ptm;
  1003.   l, ms: Integer;
  1004.   v: Int64;
  1005. begin
  1006.   v := Round((dt - 25569) * 86400000);
  1007.   ms := v mod 1000;
  1008.   l := v div 1000;
  1009.   p := localtime(@l);
  1010.   Result := Int64(mktime(p)) * 1000 + ms;
  1011. end;
  1012.  
  1013. function JavaToDelphiDateTime(const dt: int64): TDateTime;
  1014. var
  1015.   p: ptm;
  1016.   l, ms: Integer;
  1017. begin
  1018.   l := dt div 1000;
  1019.   ms := dt mod 1000;
  1020.   p := gmtime(@l);
  1021.   Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms);
  1022. end;
  1023. {$ELSE}
  1024.  
  1025. {$IFDEF WINDOWSNT_COMPATIBILITY}
  1026. function DayLightCompareDate(const date: PSystemTime;
  1027.   const compareDate: PSystemTime): Integer;
  1028. var
  1029.   limit_day, dayinsecs, weekofmonth: Integer;
  1030.   First: Word;
  1031. begin
  1032.   if (date^.wMonth < compareDate^.wMonth) then
  1033.   begin
  1034.     Result := -1; (* We are in a month before the date limit. *)
  1035.     Exit;
  1036.   end;
  1037.  
  1038.   if (date^.wMonth > compareDate^.wMonth) then
  1039.   begin
  1040.     Result := 1; (* We are in a month after the date limit. *)
  1041.     Exit;
  1042.   end;
  1043.  
  1044.   (* if year is 0 then date is in day-of-week format, otherwise
  1045.    * it's absolute date.
  1046.    *)
  1047.   if (compareDate^.wYear = 0) then
  1048.   begin
  1049.     (* compareDate.wDay is interpreted as number of the week in the month
  1050.      * 5 means: the last week in the month *)
  1051.     weekofmonth := compareDate^.wDay;
  1052.     (* calculate the day of the first DayOfWeek in the month *)
  1053.     First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1;
  1054.     limit_day := First + 7 * (weekofmonth - 1);
  1055.     (* check needed for the 5th weekday of the month *)
  1056.     if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth - 1]) then
  1057.       dec(limit_day, 7);
  1058.   end
  1059.   else
  1060.     limit_day := compareDate^.wDay;
  1061.  
  1062.   (* convert to seconds *)
  1063.   limit_day := ((limit_day * 24  + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60;
  1064.   dayinsecs := ((date^.wDay * 24  + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond;
  1065.   (* and compare *)
  1066.  
  1067.   if dayinsecs < limit_day then
  1068.     Result :=  -1 else
  1069.     if dayinsecs > limit_day then
  1070.       Result :=  1 else
  1071.       Result :=  0; (* date is equal to the date limit. *)
  1072. end;
  1073.  
  1074. function CompTimeZoneID(const pTZinfo: PTimeZoneInformation;
  1075.   lpFileTime: PFileTime; islocal: Boolean): LongWord;
  1076. var
  1077.   ret: Integer;
  1078.   beforeStandardDate, afterDaylightDate: Boolean;
  1079.   llTime: Int64;
  1080.   SysTime: TSystemTime;
  1081.   ftTemp: TFileTime;
  1082. begin
  1083.   llTime := 0;
  1084.  
  1085.   if (pTZinfo^.DaylightDate.wMonth <> 0) then
  1086.   begin
  1087.     (* if year is 0 then date is in day-of-week format, otherwise
  1088.      * it's absolute date.
  1089.      *)
  1090.     if ((pTZinfo^.StandardDate.wMonth = 0) or
  1091.         ((pTZinfo^.StandardDate.wYear = 0) and
  1092.         ((pTZinfo^.StandardDate.wDay < 1) or
  1093.         (pTZinfo^.StandardDate.wDay > 5) or
  1094.         (pTZinfo^.DaylightDate.wDay < 1) or
  1095.         (pTZinfo^.DaylightDate.wDay > 5)))) then
  1096.     begin
  1097.       SetLastError(ERROR_INVALID_PARAMETER);
  1098.       Result := TIME_ZONE_ID_INVALID;
  1099.       Exit;
  1100.     end;
  1101.  
  1102.     if (not islocal) then
  1103.     begin
  1104.       llTime := PInt64(lpFileTime)^;
  1105.       dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000);
  1106.       PInt64(@ftTemp)^ := llTime;
  1107.       lpFileTime := @ftTemp;
  1108.     end;
  1109.  
  1110.     FileTimeToSystemTime(lpFileTime^, SysTime);
  1111.  
  1112.     (* check for daylight savings *)
  1113.     ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate);
  1114.     if (ret = -2) then
  1115.     begin
  1116.       Result := TIME_ZONE_ID_INVALID;
  1117.       Exit;
  1118.     end;
  1119.  
  1120.     beforeStandardDate := ret < 0;
  1121.  
  1122.     if (not islocal) then
  1123.     begin
  1124.       dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000);
  1125.       PInt64(@ftTemp)^ := llTime;
  1126.       FileTimeToSystemTime(lpFileTime^, SysTime);
  1127.     end;
  1128.  
  1129.     ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate);
  1130.     if (ret = -2) then
  1131.     begin
  1132.       Result := TIME_ZONE_ID_INVALID;
  1133.       Exit;
  1134.     end;
  1135.  
  1136.     afterDaylightDate := ret >= 0;
  1137.  
  1138.     Result := TIME_ZONE_ID_STANDARD;
  1139.     if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then
  1140.     begin
  1141.       (* Northern hemisphere *)
  1142.       if( beforeStandardDate and afterDaylightDate) then
  1143.         Result := TIME_ZONE_ID_DAYLIGHT;
  1144.     end else    (* Down south *)
  1145.       if( beforeStandardDate or afterDaylightDate) then
  1146.         Result := TIME_ZONE_ID_DAYLIGHT;
  1147.   end else
  1148.     (* No transition date *)
  1149.     Result := TIME_ZONE_ID_UNKNOWN;
  1150. end;
  1151.  
  1152. function GetTimezoneBias(const pTZinfo: PTimeZoneInformation;
  1153.   lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean;
  1154. var
  1155.   bias: LongInt;
  1156.   tzid: LongWord;
  1157. begin
  1158.   bias := pTZinfo^.Bias;
  1159.   tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal);
  1160.  
  1161.   if( tzid = TIME_ZONE_ID_INVALID) then
  1162.   begin
  1163.     Result := False;
  1164.     Exit;
  1165.   end;
  1166.   if (tzid = TIME_ZONE_ID_DAYLIGHT) then
  1167.     inc(bias, pTZinfo^.DaylightBias)
  1168.   else if (tzid = TIME_ZONE_ID_STANDARD) then
  1169.     inc(bias, pTZinfo^.StandardBias);
  1170.   pBias^ := bias;
  1171.   Result := True;
  1172. end;
  1173.  
  1174. function SystemTimeToTzSpecificLocalTime(
  1175.   lpTimeZoneInformation: PTimeZoneInformation;
  1176.   lpUniversalTime, lpLocalTime: PSystemTime): BOOL;
  1177. var
  1178.   ft: TFileTime;
  1179.   lBias: LongInt;
  1180.   llTime: Int64;
  1181.   tzinfo: TTimeZoneInformation;
  1182. begin
  1183.   if (lpTimeZoneInformation <> nil) then
  1184.     tzinfo := lpTimeZoneInformation^ else
  1185.     if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
  1186.     begin
  1187.       Result := False;
  1188.       Exit;
  1189.     end;
  1190.  
  1191.   if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then
  1192.   begin
  1193.     Result := False;
  1194.     Exit;
  1195.   end;
  1196.   llTime := PInt64(@ft)^;
  1197.   if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then
  1198.   begin
  1199.     Result := False;
  1200.     Exit;
  1201.   end;
  1202.   (* convert minutes to 100-nanoseconds-ticks *)
  1203.   dec(llTime, Int64(lBias) * 600000000);
  1204.   PInt64(@ft)^ := llTime;
  1205.   Result := FileTimeToSystemTime(ft, lpLocalTime^);
  1206. end;
  1207.  
  1208. function TzSpecificLocalTimeToSystemTime(
  1209.     const lpTimeZoneInformation: PTimeZoneInformation;
  1210.     const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL;
  1211. var
  1212.   ft: TFileTime;
  1213.   lBias: LongInt;
  1214.   t: Int64;
  1215.   tzinfo: TTimeZoneInformation;
  1216. begin
  1217.   if (lpTimeZoneInformation <> nil) then
  1218.     tzinfo := lpTimeZoneInformation^
  1219.   else
  1220.     if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
  1221.     begin
  1222.       Result := False;
  1223.       Exit;
  1224.     end;
  1225.  
  1226.   if (not SystemTimeToFileTime(lpLocalTime^, ft)) then
  1227.   begin
  1228.     Result := False;
  1229.     Exit;
  1230.   end;
  1231.   t := PInt64(@ft)^;
  1232.   if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then
  1233.   begin
  1234.     Result := False;
  1235.     Exit;
  1236.   end;
  1237.   (* convert minutes to 100-nanoseconds-ticks *)
  1238.   inc(t, Int64(lBias) * 600000000);
  1239.   PInt64(@ft)^ := t;
  1240.   Result := FileTimeToSystemTime(ft, lpUniversalTime^);
  1241. end;
  1242. {$ELSE}
  1243. function TzSpecificLocalTimeToSystemTime(
  1244.   lpTimeZoneInformation: PTimeZoneInformation;
  1245.   lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
  1246.  
  1247. function SystemTimeToTzSpecificLocalTime(
  1248.   lpTimeZoneInformation: PTimeZoneInformation;
  1249.   lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
  1250. {$ENDIF}
  1251.  
  1252. function JavaToDelphiDateTime(const dt: int64): TDateTime;
  1253. var
  1254.   t: TSystemTime;
  1255. begin
  1256.   DateTimeToSystemTime(25569 + (dt / 86400000), t);
  1257.   SystemTimeToTzSpecificLocalTime(nil, @t, @t);
  1258.   Result := SystemTimeToDateTime(t);
  1259. end;
  1260.  
  1261. function DelphiToJavaDateTime(const dt: TDateTime): int64;
  1262. var
  1263.   t: TSystemTime;
  1264. begin
  1265.   DateTimeToSystemTime(dt, t);
  1266.   TzSpecificLocalTimeToSystemTime(nil, @t, @t);
  1267.   Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000)
  1268. end;
  1269. {$ENDIF}
  1270.  
  1271.  
  1272. function SO(const s: SOString): ISuperObject; overload;
  1273. begin
  1274.   Result := TSuperObject.ParseString(PSOChar(s), False);
  1275. end;
  1276.  
  1277. function SA(const Args: array of const): ISuperObject; overload;
  1278. type
  1279.   TByteArray = array[0..sizeof(integer) - 1] of byte;
  1280.   PByteArray = ^TByteArray;
  1281. var
  1282.   j: Integer;
  1283.   intf: IInterface;
  1284. begin
  1285.   Result := TSuperObject.Create(stArray);
  1286.   for j := 0 to length(Args) - 1 do
  1287.     with Result.AsArray do
  1288.     case TVarRec(Args[j]).VType of
  1289.       vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger));
  1290.       vtInt64   : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^));
  1291.       vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean));
  1292.       vtChar    : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar)));
  1293.       vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar)));
  1294.       vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^));
  1295.       vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^));
  1296.       vtString  : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^)));
  1297.       vtPChar   : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^)));
  1298.       vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString))));
  1299.       vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString))));
  1300.       vtInterface:
  1301.         if TVarRec(Args[j]).VInterface = nil then
  1302.           Add(nil) else
  1303.           if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then
  1304.             Add(ISuperObject(intf)) else
  1305.             Add(nil);
  1306.       vtPointer :
  1307.         if TVarRec(Args[j]).VPointer = nil then
  1308.           Add(nil) else
  1309.           Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
  1310.       vtVariant:
  1311.         Add(SO(TVarRec(Args[j]).VVariant^));
  1312.       vtObject:
  1313.         if TVarRec(Args[j]).VPointer = nil then
  1314.           Add(nil) else
  1315.           Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
  1316.       vtClass:
  1317.         if TVarRec(Args[j]).VPointer = nil then
  1318.           Add(nil) else
  1319.           Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
  1320. {$if declared(vtUnicodeString)}
  1321.       vtUnicodeString:
  1322.           Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString))));
  1323. {$ifend}
  1324.     else
  1325.       assert(false);
  1326.     end;
  1327. end;
  1328.  
  1329. function SO(const Args: array of const): ISuperObject; overload;
  1330. var
  1331.   j: Integer;
  1332.   arr: ISuperObject;
  1333. begin
  1334.   Result := TSuperObject.Create(stObject);
  1335.   arr := SA(Args);
  1336.   with arr.AsArray do
  1337.     for j := 0 to (Length div 2) - 1 do
  1338.       Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]);
  1339. end;
  1340.  
  1341. function SO(const value: Variant): ISuperObject; overload;
  1342. begin
  1343.   with TVarData(value) do
  1344.   case VType of
  1345.     varNull:     Result := nil;
  1346.     varEmpty:    Result := nil;
  1347.     varSmallInt: Result := TSuperObject.Create(VSmallInt);
  1348.     varInteger:  Result := TSuperObject.Create(VInteger);
  1349.     varSingle:   Result := TSuperObject.Create(VSingle);
  1350.     varDouble:   Result := TSuperObject.Create(VDouble);
  1351.     varCurrency: Result := TSuperObject.CreateCurrency(VCurrency);
  1352.     varDate:     Result := TSuperObject.Create(DelphiToJavaDateTime(vDate));
  1353.     varOleStr:   Result := TSuperObject.Create(SOString(VOleStr));
  1354.     varBoolean:  Result := TSuperObject.Create(VBoolean);
  1355.     varShortInt: Result := TSuperObject.Create(VShortInt);
  1356.     varByte:     Result := TSuperObject.Create(VByte);
  1357.     varWord:     Result := TSuperObject.Create(VWord);
  1358.     varLongWord: Result := TSuperObject.Create(VLongWord);
  1359.     varInt64:    Result := TSuperObject.Create(VInt64);
  1360.     varString:   Result := TSuperObject.Create(SOString(AnsiString(VString)));
  1361. {$if declared(varUString)}
  1362.     //varUString:  Result := TSuperObject.Create(SOString(string(VUString)));
  1363. {$ifend}
  1364.   else
  1365.     raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]);
  1366.   end;
  1367. end;
  1368.  
  1369. function ObjectIsError(obj: TSuperObject): boolean;
  1370. begin
  1371.   Result := PtrUInt(obj) > PtrUInt(-4000);
  1372. end;
  1373.  
  1374. function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
  1375. begin
  1376.   if obj <> nil then
  1377.     Result := typ = obj.DataType else
  1378.     Result := typ = stNull;
  1379. end;
  1380.  
  1381. function ObjectGetType(const obj: ISuperObject): TSuperType;
  1382. begin
  1383.   if obj <> nil then
  1384.     Result := obj.DataType else
  1385.     Result := stNull;
  1386. end;
  1387.  
  1388. function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
  1389. var
  1390.   i: TSuperAvlEntry;
  1391. begin
  1392.   if ObjectIsType(obj, stObject) then
  1393.   begin
  1394.     F.Ite := TSuperAvlIterator.Create(obj.AsObject);
  1395.     F.Ite.First;
  1396.     i := F.Ite.GetIter;
  1397.     if i <> nil then
  1398.     begin
  1399.       f.key := i.Name;
  1400.       f.val := i.Value;
  1401.       Result := true;
  1402.     end else
  1403.       Result := False;
  1404.   end else
  1405.     Result := False;
  1406. end;
  1407.  
  1408. function ObjectFindNext(var F: TSuperObjectIter): boolean;
  1409. var
  1410.   i: TSuperAvlEntry;
  1411. begin
  1412.   F.Ite.Next;
  1413.   i := F.Ite.GetIter;
  1414.   if i <> nil then
  1415.   begin
  1416.     f.key := i.FName;
  1417.     f.val := i.Value;
  1418.     Result := true;
  1419.   end else
  1420.     Result := False;
  1421. end;
  1422.  
  1423. procedure ObjectFindClose(var F: TSuperObjectIter);
  1424. begin
  1425.   F.Ite.Free;
  1426.   F.val := nil;
  1427. end;
  1428.  
  1429. {$IFDEF VER210}
  1430.  
  1431. function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
  1432. begin
  1433.   Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0);
  1434. end;
  1435.  
  1436. function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
  1437. begin
  1438.   Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble));
  1439. end;
  1440.  
  1441. function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
  1442. var
  1443.   g: TGUID;
  1444. begin
  1445.   value.ExtractRawData(@g);
  1446.   Result := TSuperObject.Create(
  1447.     format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x',
  1448.               [g.D1, g.D2, g.D3,
  1449.                g.D4[0], g.D4[1], g.D4[2],
  1450.                g.D4[3], g.D4[4], g.D4[5],
  1451.                g.D4[6], g.D4[7]])
  1452.   );
  1453. end;
  1454.  
  1455. function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
  1456. var
  1457.   o: ISuperObject;
  1458. begin
  1459.   case ObjectGetType(obj) of
  1460.   stBoolean:
  1461.     begin
  1462.       TValueData(Value).FAsSLong := obj.AsInteger;
  1463.       Result := True;
  1464.     end;
  1465.   stInt:
  1466.     begin
  1467.       TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0);
  1468.       Result := True;
  1469.     end;
  1470.   stString:
  1471.     begin
  1472.       o := SO(obj.AsString);
  1473.       if not ObjectIsType(o, stString) then
  1474.         Result := serialfromboolean(ctx, SO(obj.AsString), Value) else
  1475.         Result := False;
  1476.     end;
  1477.   else
  1478.     Result := False;
  1479.   end;
  1480. end;
  1481.  
  1482. function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
  1483. var
  1484.   dt: TDateTime;
  1485. begin
  1486.   case ObjectGetType(obj) of
  1487.   stInt:
  1488.     begin
  1489.       TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger);
  1490.       Result := True;
  1491.     end;
  1492.   stString:
  1493.     begin
  1494.       if TryStrToDateTime(obj.AsString, dt) then
  1495.       begin
  1496.         TValueData(Value).FAsDouble := dt;
  1497.         Result := True;
  1498.       end else
  1499.         Result := False;
  1500.     end;
  1501.   else
  1502.     Result := False;
  1503.   end;
  1504. end;
  1505.  
  1506. function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean;
  1507. const
  1508.   hex2bin: array[#0..#102] of short = (
  1509.     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,        (* 0x00 *)
  1510.     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,        (* 0x10 *)
  1511.     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,        (* 0x20 *)
  1512.      0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1,        (* 0x30 *)
  1513.     -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,        (* 0x40 *)
  1514.     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,        (* 0x50 *)
  1515.     -1,10,11,12,13,14,15);                                  (* 0x60 *)
  1516. var
  1517.   i: Integer;
  1518. begin
  1519.   if (strlen(s) <> 36) then Exit(False);
  1520.  
  1521.   if ((s[8] <> '-') or (s[13] <> '-') or (s[18] <> '-') or (s[23] <> '-')) then
  1522.      Exit(False);
  1523.  
  1524.   for i := 0 to 35 do
  1525.   begin
  1526.     if not i in [8,13,18,23] then
  1527.       if ((s[i] > 'f') or ((hex2bin[s[i]] = -1) and (s[i] <> ''))) then
  1528.         Exit(False);
  1529.   end;
  1530.  
  1531.   uuid.D1 := ((hex2bin[s[0]] shl 28) or (hex2bin[s[1]] shl 24) or (hex2bin[s[2]] shl 20) or (hex2bin[s[3]] shl 16) or
  1532.                 (hex2bin[s[4]] shl 12) or (hex2bin[s[5]] shl 8) or (hex2bin[s[6]]  shl 4) or hex2bin[s[7]]);
  1533.   uuid.D2 := (hex2bin[s[9]] shl 12) or (hex2bin[s[10]] shl 8) or (hex2bin[s[11]] shl 4) or hex2bin[s[12]];
  1534.   uuid.D3 := (hex2bin[s[14]] shl 12) or (hex2bin[s[15]] shl 8) or (hex2bin[s[16]] shl 4) or hex2bin[s[17]];
  1535.  
  1536.   uuid.D4[0] := (hex2bin[s[19]] shl 4) or hex2bin[s[20]];
  1537.   uuid.D4[1] := (hex2bin[s[21]] shl 4) or hex2bin[s[22]];
  1538.   uuid.D4[2] := (hex2bin[s[24]] shl 4) or hex2bin[s[25]];
  1539.   uuid.D4[3] := (hex2bin[s[26]] shl 4) or hex2bin[s[27]];
  1540.   uuid.D4[4] := (hex2bin[s[28]] shl 4) or hex2bin[s[29]];
  1541.   uuid.D4[5] := (hex2bin[s[30]] shl 4) or hex2bin[s[31]];
  1542.   uuid.D4[6] := (hex2bin[s[32]] shl 4) or hex2bin[s[33]];
  1543.   uuid.D4[7] := (hex2bin[s[34]] shl 4) or hex2bin[s[35]];
  1544.   Result := True;
  1545. end;
  1546.  
  1547. function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
  1548. begin
  1549.   case ObjectGetType(obj) of
  1550.     stNull:
  1551.       begin
  1552.         FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0);
  1553.         Result := True;
  1554.       end;
  1555.     stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData);
  1556.   else
  1557.     Result := False;
  1558.   end;
  1559. end;
  1560.  
  1561. function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload;
  1562. var
  1563.   owned: Boolean;
  1564. begin
  1565.   if ctx = nil then
  1566.   begin
  1567.     ctx := TSuperRttiContext.Create;
  1568.     owned := True;
  1569.   end else
  1570.     owned := False;
  1571.   try
  1572.     if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then
  1573.       raise Exception.Create('Invalid method call');
  1574.   finally
  1575.     if owned then
  1576.       ctx.Free;
  1577.   end;
  1578. end;
  1579.  
  1580. function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload;
  1581. begin
  1582.   Result := SOInvoke(obj, method, so(params), ctx)
  1583. end;
  1584.  
  1585. function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue;
  1586.   const method: string; const params: ISuperObject;
  1587.   var Return: ISuperObject): TSuperInvokeResult;
  1588. var
  1589.   t: TRttiInstanceType;
  1590.   m: TRttiMethod;
  1591.   a: TArray<TValue>;
  1592.   ps: TArray<TRttiParameter>;
  1593.   v: TValue;
  1594.   index: ISuperObject;
  1595.  
  1596.   function GetParams: Boolean;
  1597.   var
  1598.     i: Integer;
  1599.   begin
  1600.     case ObjectGetType(params) of
  1601.       stArray:
  1602.         for i := 0 to Length(ps) - 1 do
  1603.           if (pfOut in ps[i].Flags) then
  1604.             TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
  1605.             if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then
  1606.               Exit(False);
  1607.       stObject:
  1608.         for i := 0 to Length(ps) - 1 do
  1609.           if (pfOut in ps[i].Flags) then
  1610.             TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
  1611.             if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then
  1612.               Exit(False);
  1613.       stNull: ;
  1614.     else
  1615.       Exit(False);
  1616.     end;
  1617.     Result := True;
  1618.   end;
  1619.  
  1620.   procedure SetParams;
  1621.   var
  1622.     i: Integer;
  1623.   begin
  1624.     case ObjectGetType(params) of
  1625.       stArray:
  1626.         for i := 0 to Length(ps) - 1 do
  1627.           if (ps[i].Flags * [pfVar, pfOut]) <> [] then
  1628.             params.AsArray[i] := ctx.ToJson(a[i], index);
  1629.       stObject:
  1630.         for i := 0 to Length(ps) - 1 do
  1631.           if (ps[i].Flags * [pfVar, pfOut]) <> [] then
  1632.             params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index);
  1633.     end;
  1634.   end;
  1635.  
  1636. begin
  1637.   Result := irSuccess;
  1638.   index := SO;
  1639.   case obj.Kind of
  1640.     tkClass:
  1641.       begin
  1642.         t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType));
  1643.         m := t.GetMethod(method);
  1644.         if m = nil then Exit(irMethothodError);
  1645.         ps := m.GetParameters;
  1646.         SetLength(a, Length(ps));
  1647.         if not GetParams then Exit(irParamError);
  1648.         if m.IsClassMethod then
  1649.         begin
  1650.           v := m.Invoke(obj.AsObject.ClassType, a);
  1651.           Return := ctx.ToJson(v, index);
  1652.           SetParams;
  1653.         end else
  1654.         begin
  1655.           v := m.Invoke(obj, a);
  1656.           Return := ctx.ToJson(v, index);
  1657.           SetParams;
  1658.         end;
  1659.       end;
  1660.     tkClassRef:
  1661.       begin
  1662.         t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass));
  1663.         m := t.GetMethod(method);
  1664.         if m = nil then Exit(irMethothodError);
  1665.         ps := m.GetParameters;
  1666.         SetLength(a, Length(ps));
  1667.  
  1668.         if not GetParams then Exit(irParamError);
  1669.         if m.IsClassMethod then
  1670.         begin
  1671.           v := m.Invoke(obj, a);
  1672.           Return := ctx.ToJson(v, index);
  1673.           SetParams;
  1674.         end else
  1675.           Exit(irError);
  1676.       end;
  1677.   else
  1678.     Exit(irError);
  1679.   end;
  1680. end;
  1681.  
  1682. {$ENDIF}
  1683.  
  1684. { TSuperEnumerator }
  1685.  
  1686. constructor TSuperEnumerator.Create(const obj: ISuperObject);
  1687. begin
  1688.   FObj := obj;
  1689.   FCount := -1;
  1690.   if ObjectIsType(FObj, stObject) then
  1691.     FObjEnum := FObj.AsObject.GetEnumerator else
  1692.     FObjEnum := nil;
  1693. end;
  1694.  
  1695. destructor TSuperEnumerator.Destroy;
  1696. begin
  1697.   if FObjEnum <> nil then
  1698.     FObjEnum.Free;
  1699. end;
  1700.  
  1701. function TSuperEnumerator.MoveNext: Boolean;
  1702. begin
  1703.   case ObjectGetType(FObj) of
  1704.     stObject: Result := FObjEnum.MoveNext;
  1705.     stArray:
  1706.       begin
  1707.         inc(FCount);
  1708.         if FCount < FObj.AsArray.Length then
  1709.           Result := True else
  1710.           Result := False;
  1711.       end;
  1712.   else
  1713.     Result := false;
  1714.   end;
  1715. end;
  1716.  
  1717. function TSuperEnumerator.GetCurrent: ISuperObject;
  1718. begin
  1719.   case ObjectGetType(FObj) of
  1720.     stObject: Result := FObjEnum.Current.Value;
  1721.     stArray: Result := FObj.AsArray.GetO(FCount);
  1722.   else
  1723.     Result := FObj;
  1724.   end;
  1725. end;
  1726.  
  1727. { TSuperObject }
  1728.  
  1729. constructor TSuperObject.Create(jt: TSuperType);
  1730. begin
  1731.   inherited Create;
  1732. {$IFDEF DEBUG}
  1733.   InterlockedIncrement(debugcount);
  1734. {$ENDIF}
  1735.  
  1736.   FProcessing := false;
  1737.   FDataPtr := nil;
  1738.   FDataType := jt;
  1739.   case FDataType of
  1740.     stObject: FO.c_object := TSuperTableString.Create;
  1741.     stArray: FO.c_array := TSuperArray.Create;
  1742.     stString: FOString := '';
  1743.   else
  1744.     FO.c_object := nil;
  1745.   end;
  1746. end;
  1747.  
  1748. constructor TSuperObject.Create(b: boolean);
  1749. begin
  1750.   Create(stBoolean);
  1751.   FO.c_boolean := b;
  1752. end;
  1753.  
  1754. constructor TSuperObject.Create(i: SuperInt);
  1755. begin
  1756.   Create(stInt);
  1757.   FO.c_int := i;
  1758. end;
  1759.  
  1760. constructor TSuperObject.Create(d: double);
  1761. begin
  1762.   Create(stDouble);
  1763.   FO.c_double := d;
  1764. end;
  1765.  
  1766. constructor TSuperObject.CreateCurrency(c: Currency);
  1767. begin
  1768.   Create(stCurrency);
  1769.   FO.c_currency := c;
  1770. end;
  1771.  
  1772. destructor TSuperObject.Destroy;
  1773. begin
  1774. {$IFDEF DEBUG}
  1775.   InterlockedDecrement(debugcount);
  1776. {$ENDIF}
  1777.   case FDataType of
  1778.     stObject: FO.c_object.Free;
  1779.     stArray: FO.c_array.Free;
  1780.   end;
  1781.   inherited;
  1782. end;
  1783.  
  1784. function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
  1785. function DoEscape(str: PSOChar; len: Integer): Integer;
  1786. var
  1787.   pos, start_offset: Integer;
  1788.   c: SOChar;
  1789.   buf: array[0..5] of SOChar;
  1790. type
  1791.   TByteChar = record
  1792.   case integer of
  1793.     0: (a, b: Byte);
  1794.     1: (c: WideChar);
  1795.   end;
  1796.   begin
  1797.     if str = nil then
  1798.     begin
  1799.       Result := 0;
  1800.       exit;
  1801.     end;
  1802.     pos := 0; start_offset := 0;
  1803.     with writer do
  1804.     while pos < len do
  1805.     begin
  1806.       c := str[pos];
  1807.       case c of
  1808.         #8,#9,#10,#12,#13,'"','\','/':
  1809.           begin
  1810.             if(pos - start_offset > 0) then
  1811.               Append(str + start_offset, pos - start_offset);
  1812.  
  1813.             if(c = #8) then Append(ESC_BS, 2)
  1814.             else if (c = #9) then Append(ESC_TAB, 2)
  1815.             else if (c = #10) then Append(ESC_LF, 2)
  1816.             else if (c = #12) then Append(ESC_FF, 2)
  1817.             else if (c = #13) then Append(ESC_CR, 2)
  1818.             else if (c = '"') then Append(ESC_QUOT, 2)
  1819.             else if (c = '\') then Append(ESC_SL, 2)
  1820.             else if (c = '/') then Append(ESC_SR, 2);
  1821.             inc(pos);
  1822.             start_offset := pos;
  1823.           end;
  1824.       else
  1825.         if (SOIChar(c) > 255) then
  1826.         begin
  1827.           if(pos - start_offset > 0) then
  1828.             Append(str + start_offset, pos - start_offset);
  1829.           buf[0] := '\';
  1830.           buf[1] := 'u';
  1831.           buf[2] := super_hex_chars[TByteChar(c).b shr 4];
  1832.           buf[3] := super_hex_chars[TByteChar(c).b and $f];
  1833.           buf[4] := super_hex_chars[TByteChar(c).a shr 4];
  1834.           buf[5] := super_hex_chars[TByteChar(c).a and $f];
  1835.           Append(@buf, 6);
  1836.           inc(pos);
  1837.           start_offset := pos;
  1838.         end else
  1839.         if (c < #32) or (c > #127) then
  1840.         begin
  1841.           if(pos - start_offset > 0) then
  1842.             Append(str + start_offset, pos - start_offset);
  1843.           buf[0] := '\';
  1844.           buf[1] := 'u';
  1845.           buf[2] := '0';
  1846.           buf[3] := '0';
  1847.           buf[4] := super_hex_chars[ord(c) shr 4];
  1848.           buf[5] := super_hex_chars[ord(c) and $f];
  1849.           Append(buf, 6);
  1850.           inc(pos);
  1851.           start_offset := pos;
  1852.         end else
  1853.           inc(pos);
  1854.       end;
  1855.     end;
  1856.     if(pos - start_offset > 0) then
  1857.       writer.Append(str + start_offset, pos - start_offset);
  1858.     Result := 0;
  1859.   end;
  1860.  
  1861. function DoMinimalEscape(str: PSOChar; len: Integer): Integer;
  1862. var
  1863.   pos, start_offset: Integer;
  1864.   c: SOChar;
  1865. type
  1866.   TByteChar = record
  1867.   case integer of
  1868.     0: (a, b: Byte);
  1869.     1: (c: WideChar);
  1870.   end;
  1871.   begin
  1872.     if str = nil then
  1873.     begin
  1874.       Result := 0;
  1875.       exit;
  1876.     end;
  1877.     pos := 0; start_offset := 0;
  1878.     with writer do
  1879.     while pos < len do
  1880.     begin
  1881.       c := str[pos];
  1882.       case c of
  1883.         #0:
  1884.           begin
  1885.             if(pos - start_offset > 0) then
  1886.               Append(str + start_offset, pos - start_offset);
  1887.             Append(ESC_ZERO, 6);
  1888.             inc(pos);
  1889.             start_offset := pos;
  1890.           end;
  1891.         '"':
  1892.           begin
  1893.             if(pos - start_offset > 0) then
  1894.               Append(str + start_offset, pos - start_offset);
  1895.             Append(ESC_QUOT, 2);
  1896.             inc(pos);
  1897.             start_offset := pos;
  1898.           end;
  1899.         '\':
  1900.           begin
  1901.             if(pos - start_offset > 0) then
  1902.               Append(str + start_offset, pos - start_offset);
  1903.             Append(ESC_SL, 2);
  1904.             inc(pos);
  1905.             start_offset := pos;
  1906.           end;
  1907.         '/':
  1908.           begin
  1909.             if(pos - start_offset > 0) then
  1910.               Append(str + start_offset, pos - start_offset);
  1911.             Append(ESC_SR, 2);
  1912.             inc(pos);
  1913.             start_offset := pos;
  1914.           end;
  1915.       else
  1916.         inc(pos);
  1917.       end;
  1918.     end;
  1919.     if(pos - start_offset > 0) then
  1920.       writer.Append(str + start_offset, pos - start_offset);
  1921.     Result := 0;
  1922.   end;
  1923.  
  1924.  
  1925.   procedure _indent(i: shortint; r: boolean);
  1926.   begin
  1927.     inc(level, i);
  1928.     if r then
  1929.       with writer do
  1930.       begin
  1931. {$IFDEF MSWINDOWS}
  1932.         Append(TOK_CRLF, 2);
  1933. {$ELSE}
  1934.         Append(TOK_LF, 1);
  1935. {$ENDIF}
  1936.         for i := 0 to level - 1 do
  1937.           Append(TOK_SP, 1);
  1938.       end;
  1939.   end;
  1940. var
  1941.   k,j: Integer;
  1942.   iter: TSuperObjectIter;
  1943.   st: AnsiString;
  1944.   val: ISuperObject;
  1945.   fbuffer: array[0..31] of AnsiChar;
  1946. const
  1947.   ENDSTR_A: PSOChar = '": ';
  1948.   ENDSTR_B: PSOChar = '":';
  1949. begin
  1950.  
  1951.   if FProcessing then
  1952.   begin
  1953.     Result := writer.Append(TOK_NULL, 4);
  1954.     Exit;
  1955.   end;
  1956.  
  1957.   FProcessing := true;
  1958.   with writer do
  1959.   try
  1960.     case FDataType of
  1961.       stObject:
  1962.         if FO.c_object.FCount > 0 then
  1963.         begin
  1964.           k := 0;
  1965.           Append(TOK_CBL, 1);
  1966.           if indent then _indent(1, false);
  1967.           if ObjectFindFirst(Self, iter) then
  1968.           repeat
  1969.   {$IFDEF SUPER_METHOD}
  1970.             if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then
  1971.             begin
  1972.   {$ENDIF}
  1973.               if (iter.val = nil) or (not iter.val.Processing) then
  1974.               begin
  1975.                 if(k <> 0) then
  1976.                   Append(TOK_COM, 1);
  1977.                 if indent then _indent(0, true);
  1978.                 Append(TOK_DQT, 1);
  1979.                 if escape then
  1980.                   doEscape(PSOChar(iter.key), Length(iter.key)) else
  1981.                   DoMinimalEscape(PSOChar(iter.key), Length(iter.key));
  1982.                 if indent then
  1983.                   Append(ENDSTR_A, 3) else
  1984.                   Append(ENDSTR_B, 2);
  1985.                 if(iter.val = nil) then
  1986.                   Append(TOK_NULL, 4) else
  1987.                   iter.val.write(writer, indent, escape, level);
  1988.                 inc(k);
  1989.               end;
  1990.   {$IFDEF SUPER_METHOD}
  1991.             end;
  1992.   {$ENDIF}
  1993.           until not ObjectFindNext(iter);
  1994.           ObjectFindClose(iter);
  1995.           if indent then _indent(-1, true);
  1996.           Result := Append(TOK_CBR, 1);
  1997.         end else
  1998.           Result := Append(TOK_OBJ, 2);
  1999.       stBoolean:
  2000.         begin
  2001.           if (FO.c_boolean) then
  2002.             Result := Append(TOK_TRUE, 4) else
  2003.             Result := Append(TOK_FALSE, 5);
  2004.         end;
  2005.       stInt:
  2006.         begin
  2007.           str(FO.c_int, st);
  2008.           Result := Append(PSOChar(SOString(st)));
  2009.         end;
  2010.       stDouble:
  2011.         Result := Append(PSOChar(SOString(gcvt(FO.c_double, 15, fbuffer))));
  2012.       stCurrency:
  2013.         begin
  2014.           Result := Append(PSOChar(CurrToStr(FO.c_currency)));
  2015.         end;
  2016.       stString:
  2017.         begin
  2018.           Append(TOK_DQT, 1);
  2019.           if escape then
  2020.             doEscape(PSOChar(FOString), Length(FOString)) else
  2021.             DoMinimalEscape(PSOChar(FOString), Length(FOString));
  2022.           Append(TOK_DQT, 1);
  2023.           Result := 0;
  2024.         end;
  2025.       stArray:
  2026.         if FO.c_array.FLength > 0 then
  2027.         begin
  2028.           Append(TOK_ARL, 1);
  2029.           if indent then _indent(1, true);
  2030.           k := 0;
  2031.           j := 0;
  2032.           while k < FO.c_array.FLength do
  2033.           begin
  2034.  
  2035.             val :=  FO.c_array.GetO(k);
  2036.   {$IFDEF SUPER_METHOD}
  2037.             if not ObjectIsType(val, stMethod) then
  2038.             begin
  2039.   {$ENDIF}
  2040.               if (val = nil) or (not val.Processing) then
  2041.               begin
  2042.                 if (j <> 0) then
  2043.                   Append(TOK_COM, 1);
  2044.                 if(val = nil) then
  2045.                   Append(TOK_NULL, 4) else
  2046.                   val.write(writer, indent, escape, level);
  2047.                 inc(j);
  2048.               end;
  2049.   {$IFDEF SUPER_METHOD}
  2050.             end;
  2051.   {$ENDIF}
  2052.             inc(k);
  2053.           end;
  2054.           if indent then _indent(-1, false);
  2055.           Result := Append(TOK_ARR, 1);
  2056.         end else
  2057.           Result := Append(TOK_ARRAY, 2);
  2058.       stNull:
  2059.           Result := Append(TOK_NULL, 4);
  2060.     else
  2061.       Result := 0;
  2062.     end;
  2063.   finally
  2064.     FProcessing := false;
  2065.   end;
  2066. end;
  2067.  
  2068. function TSuperObject.IsType(AType: TSuperType): boolean;
  2069. begin
  2070.   Result := AType = FDataType;
  2071. end;
  2072.  
  2073. function TSuperObject.AsBoolean: boolean;
  2074. begin
  2075.   case FDataType of
  2076.     stBoolean: Result := FO.c_boolean;
  2077.     stInt: Result := (FO.c_int <> 0);
  2078.     stDouble: Result := (FO.c_double <> 0);
  2079.     stCurrency: Result := (FO.c_currency <> 0);
  2080.     stString: Result := (Length(FOString) <> 0);
  2081.     stNull: Result := False;
  2082.   else
  2083.     Result := True;
  2084.   end;
  2085. end;
  2086.  
  2087. function TSuperObject.AsInteger: SuperInt;
  2088. var
  2089.   code: integer;
  2090.   cint: SuperInt;
  2091. begin
  2092.   case FDataType of
  2093.     stInt: Result := FO.c_int;
  2094.     stDouble: Result := round(FO.c_double);
  2095.     stCurrency: Result := round(FO.c_currency);
  2096.     stBoolean: Result := ord(FO.c_boolean);
  2097.     stString:
  2098.       begin
  2099.         Val(FOString, cint, code);
  2100.         if code = 0 then
  2101.           Result := cint else
  2102.           Result := 0;
  2103.       end;
  2104.   else
  2105.     Result := 0;
  2106.   end;
  2107. end;
  2108.  
  2109. function TSuperObject.AsDouble: Double;
  2110. var
  2111.   code: integer;
  2112.   cdouble: double;
  2113. begin
  2114.   case FDataType of
  2115.     stDouble: Result := FO.c_double;
  2116.     stCurrency: Result := FO.c_currency;
  2117.     stInt: Result := FO.c_int;
  2118.     stBoolean: Result := ord(FO.c_boolean);
  2119.     stString:
  2120.       begin
  2121.         Val(FOString, cdouble, code);
  2122.         if code = 0 then
  2123.           Result := cdouble else
  2124.           Result := 0.0;
  2125.       end;
  2126.   else
  2127.     Result := 0.0;
  2128.   end;
  2129. end;
  2130.  
  2131. function TSuperObject.AsCurrency: Currency;
  2132. var
  2133.   code: integer;
  2134.   cdouble: double;
  2135. begin
  2136.   case FDataType of
  2137.     stDouble: Result := FO.c_double;
  2138.     stCurrency: Result := FO.c_currency;
  2139.     stInt: Result := FO.c_int;
  2140.     stBoolean: Result := ord(FO.c_boolean);
  2141.     stString:
  2142.       begin
  2143.         Val(FOString, cdouble, code);
  2144.         if code = 0 then
  2145.           Result := cdouble else
  2146.           Result := 0.0;
  2147.       end;
  2148.   else
  2149.     Result := 0.0;
  2150.   end;
  2151. end;
  2152.  
  2153. function TSuperObject.AsString: SOString;
  2154. begin
  2155.   if FDataType = stString then
  2156.     Result := FOString else
  2157.     Result := AsJSon(false, false);
  2158. end;
  2159.  
  2160. function TSuperObject.GetEnumerator: TSuperEnumerator;
  2161. begin
  2162.   Result := TSuperEnumerator.Create(Self);
  2163. end;
  2164.  
  2165. procedure TSuperObject.AfterConstruction;
  2166. begin
  2167.   InterlockedDecrement(FRefCount);
  2168. end;
  2169.  
  2170. procedure TSuperObject.BeforeDestruction;
  2171. begin
  2172.   if RefCount <> 0 then
  2173.     raise Exception.Create('Invalid pointer');
  2174. end;
  2175.  
  2176. function TSuperObject.AsArray: TSuperArray;
  2177. begin
  2178.   if FDataType = stArray then
  2179.     Result := FO.c_array else
  2180.     Result := nil;
  2181. end;
  2182.  
  2183. function TSuperObject.AsObject: TSuperTableString;
  2184. begin
  2185.   if FDataType = stObject then
  2186.     Result := FO.c_object else
  2187.     Result := nil;
  2188. end;
  2189.  
  2190. function TSuperObject.AsJSon(indent, escape: boolean): SOString;
  2191. var
  2192.   pb: TSuperWriterString;
  2193. begin
  2194.   pb := TSuperWriterString.Create;
  2195.   try
  2196.     if(Write(pb, indent, escape, 0) < 0) then
  2197.     begin
  2198.       Result := '';
  2199.       Exit;
  2200.     end;
  2201.     if pb.FBPos > 0 then
  2202.       Result := pb.FBuf else
  2203.       Result := '';
  2204.   finally
  2205.     pb.Free;
  2206.   end;
  2207. end;
  2208.  
  2209. class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject;
  2210.   options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
  2211. var
  2212.   tok: TSuperTokenizer;
  2213.   obj: ISuperObject;
  2214. begin
  2215.   tok := TSuperTokenizer.Create;
  2216.   obj := ParseEx(tok, s, -1, strict, this, options, put, dt);
  2217.   if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then
  2218.     Result := nil else
  2219.     Result := obj;
  2220.   tok.Free;
  2221. end;
  2222.  
  2223. class function TSuperObject.ParseStream(stream: TStream; strict: Boolean;
  2224.   partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
  2225.    const put: ISuperObject; dt: TSuperType): ISuperObject;
  2226. const
  2227.   BUFFER_SIZE = 1024;
  2228. var
  2229.   tok: TSuperTokenizer;
  2230.   buffera: array[0..BUFFER_SIZE-1] of AnsiChar;
  2231.   bufferw: array[0..BUFFER_SIZE-1] of SOChar;
  2232.   bom: array[0..1] of byte;
  2233.   unicode: boolean;
  2234.   j, size: Integer;
  2235.   st: string;
  2236. begin
  2237.   st := '';
  2238.   tok := TSuperTokenizer.Create;
  2239.  
  2240.   if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then
  2241.   begin
  2242.     unicode := true;
  2243.     size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
  2244.   end else
  2245.     begin
  2246.       unicode := false;
  2247.       stream.Seek(0, soFromBeginning);
  2248.       size := stream.Read(buffera, BUFFER_SIZE);
  2249.     end;
  2250.  
  2251.   while size > 0 do
  2252.   begin
  2253.     if not unicode then
  2254.       for j := 0 to size - 1 do
  2255.         bufferw[j] := SOChar(buffera[j]);
  2256.     ParseEx(tok, bufferw, size, strict, this, options, put, dt);
  2257.  
  2258.     if tok.err = teContinue then
  2259.       begin
  2260.         if not unicode then
  2261.           size := stream.Read(buffera, BUFFER_SIZE) else
  2262.           size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
  2263.       end else
  2264.       Break;
  2265.   end;
  2266.   if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then
  2267.     Result := nil else
  2268.     Result := tok.stack[tok.depth].current;
  2269.   tok.Free;
  2270. end;
  2271.  
  2272. class function TSuperObject.ParseFile(const FileName: string; strict: Boolean;
  2273.   partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
  2274.   const put: ISuperObject; dt: TSuperType): ISuperObject;
  2275. var
  2276.   stream: TFileStream;
  2277. begin
  2278.   stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite);
  2279.   try
  2280.     Result := ParseStream(stream, strict, partial, this, options, put, dt);
  2281.   finally
  2282.     stream.Free;
  2283.   end;
  2284. end;
  2285.  
  2286. class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer;
  2287.   strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
  2288.  
  2289. const
  2290.   spaces = [#32,#8,#9,#10,#12,#13];
  2291.   delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0];
  2292.   reserved = delimiters + spaces;
  2293.   path = ['a'..'z', 'A'..'Z', '.', '_'];
  2294.  
  2295.   function hexdigit(x: SOChar): byte;
  2296.   begin
  2297.     if x <= '9' then
  2298.       Result := byte(x) - byte('0') else
  2299.       Result := (byte(x) and 7) + 9;
  2300.   end;
  2301.   function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end;
  2302.  
  2303. var
  2304.   obj: ISuperObject;
  2305.   v: SOChar;
  2306. {$IFDEF SUPER_METHOD}
  2307.   sm: TSuperMethod;
  2308. {$ENDIF}
  2309.   numi: SuperInt;
  2310.   numd: Double;
  2311.   code: integer;
  2312.   TokRec: PSuperTokenerSrec;
  2313.   evalstack: integer;
  2314.   p: PSOChar;
  2315.  
  2316.   function IsEndDelimiter(v: AnsiChar): Boolean;
  2317.   begin
  2318.     if tok.depth > 0 then
  2319.       case tok.stack[tok.depth - 1].state of
  2320.         tsArrayAdd: Result := v in [',', ']', #0];
  2321.         tsObjectValueAdd: Result := v in [',', '}', #0];
  2322.       else
  2323.         Result := v = #0;
  2324.       end else
  2325.         Result := v = #0;
  2326.   end;
  2327.  
  2328. label out, redo_char;
  2329. begin
  2330.   evalstack := 0;
  2331.   obj := nil;
  2332.   Result := nil;
  2333.   TokRec := @tok.stack[tok.depth];
  2334.  
  2335.   tok.char_offset := 0;
  2336.   tok.err := teSuccess;
  2337.  
  2338.   repeat
  2339.     if (tok.char_offset = len) then
  2340.     begin
  2341.       if (tok.depth = 0) and (TokRec^.state = tsEatws) and
  2342.          (TokRec^.saved_state = tsFinish) then
  2343.         tok.err := teSuccess else
  2344.         tok.err := teContinue;
  2345.       goto out;
  2346.     end;
  2347.  
  2348.     v := str^;
  2349.  
  2350.     case v of
  2351.     #10:
  2352.       begin
  2353.         inc(tok.line);
  2354.         tok.col := 0;
  2355.       end;
  2356.     #9: inc(tok.col, 4);
  2357.     else
  2358.       inc(tok.col);
  2359.     end;
  2360.  
  2361. redo_char:
  2362.     case TokRec^.state of
  2363.     tsEatws:
  2364.       begin
  2365.         if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else
  2366.         if (v = '/') then
  2367.         begin
  2368.           tok.pb.Reset;
  2369.           tok.pb.Append(@v, 1);
  2370.           TokRec^.state := tsCommentStart;
  2371.         end else begin
  2372.           TokRec^.state := TokRec^.saved_state;
  2373.           goto redo_char;
  2374.         end
  2375.       end;
  2376.  
  2377.     tsStart:
  2378.       case v of
  2379.       '"',
  2380.       '''':
  2381.         begin
  2382.           TokRec^.state := tsString;
  2383.           tok.pb.Reset;
  2384.           tok.quote_char := v;
  2385.         end;
  2386.       '-':
  2387.         begin
  2388.           TokRec^.state := tsNumber;
  2389.           tok.pb.Reset;
  2390.           tok.is_double := 0;
  2391.           tok.floatcount := -1;
  2392.           goto redo_char;
  2393.         end;
  2394.  
  2395.       '0'..'9':
  2396.         begin
  2397.           if (tok.depth = 0) then
  2398.             case ObjectGetType(this) of
  2399.             stObject:
  2400.               begin
  2401.                 TokRec^.state := tsIdentifier;
  2402.                 TokRec^.current := this;
  2403.                 goto redo_char;
  2404.               end;
  2405.           end;
  2406.           TokRec^.state := tsNumber;
  2407.           tok.pb.Reset;
  2408.           tok.is_double := 0;
  2409.           tok.floatcount := -1;
  2410.           goto redo_char;
  2411.         end;
  2412.       '{':
  2413.         begin
  2414.           TokRec^.state := tsEatws;
  2415.           TokRec^.saved_state := tsObjectFieldStart;
  2416.           TokRec^.current := TSuperObject.Create(stObject);
  2417.         end;
  2418.       '[':
  2419.         begin
  2420.           TokRec^.state := tsEatws;
  2421.           TokRec^.saved_state := tsArray;
  2422.           TokRec^.current := TSuperObject.Create(stArray);
  2423.         end;
  2424. {$IFDEF SUPER_METHOD}
  2425.       '(':
  2426.         begin
  2427.           if (tok.depth = 0) and ObjectIsType(this, stMethod) then
  2428.           begin
  2429.             TokRec^.current := this;
  2430.             TokRec^.state := tsParamValue;
  2431.           end;
  2432.         end;
  2433. {$ENDIF}
  2434.       'N',
  2435.       'n':
  2436.         begin
  2437.           TokRec^.state := tsNull;
  2438.           tok.pb.Reset;
  2439.           tok.st_pos := 0;
  2440.           goto redo_char;
  2441.         end;
  2442.       'T',
  2443.       't',
  2444.       'F',
  2445.       'f':
  2446.         begin
  2447.           TokRec^.state := tsBoolean;
  2448.           tok.pb.Reset;
  2449.           tok.st_pos := 0;
  2450.           goto redo_char;
  2451.         end;
  2452.       else
  2453.         TokRec^.state := tsIdentifier;
  2454.         tok.pb.Reset;
  2455.         goto redo_char;
  2456.       end;
  2457.  
  2458.     tsFinish:
  2459.       begin
  2460.         if(tok.depth = 0) then goto out;
  2461.         obj := TokRec^.current;
  2462.         tok.ResetLevel(tok.depth);
  2463.         dec(tok.depth);
  2464.         TokRec := @tok.stack[tok.depth];
  2465.         goto redo_char;
  2466.       end;
  2467.  
  2468.     tsNull:
  2469.       begin
  2470.         tok.pb.Append(@v, 1);
  2471.         if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
  2472.         begin
  2473.           if (tok.st_pos = 4) then
  2474.           if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
  2475.             TokRec^.state := tsIdentifier else
  2476.           begin
  2477.             TokRec^.current := TSuperObject.Create(stNull);
  2478.             TokRec^.saved_state := tsFinish;
  2479.             TokRec^.state := tsEatws;
  2480.             goto redo_char;
  2481.           end;
  2482.         end else
  2483.         begin
  2484.           TokRec^.state := tsIdentifier;
  2485.           tok.pb.FBuf[tok.st_pos] := #0;
  2486.           dec(tok.pb.FBPos);
  2487.           goto redo_char;
  2488.         end;
  2489.         inc(tok.st_pos);
  2490.       end;
  2491.  
  2492.     tsCommentStart:
  2493.       begin
  2494.         if(v = '*') then
  2495.         begin
  2496.           TokRec^.state := tsComment;
  2497.         end else
  2498.         if (v = '/') then
  2499.         begin
  2500.           TokRec^.state := tsCommentEol;
  2501.         end else
  2502.         begin
  2503.           tok.err := teParseComment;
  2504.           goto out;
  2505.         end;
  2506.         tok.pb.Append(@v, 1);
  2507.       end;
  2508.  
  2509.     tsComment:
  2510.       begin
  2511.         if(v = '*') then
  2512.           TokRec^.state := tsCommentEnd;
  2513.         tok.pb.Append(@v, 1);
  2514.       end;
  2515.  
  2516.     tsCommentEol:
  2517.       begin
  2518.         if (v = #10) then
  2519.           TokRec^.state := tsEatws else
  2520.           tok.pb.Append(@v, 1);
  2521.       end;
  2522.  
  2523.     tsCommentEnd:
  2524.       begin
  2525.         tok.pb.Append(@v, 1);
  2526.         if (v = '/') then
  2527.           TokRec^.state := tsEatws else
  2528.           TokRec^.state := tsComment;
  2529.       end;
  2530.  
  2531.     tsString:
  2532.       begin
  2533.         if (v = tok.quote_char) then
  2534.         begin
  2535.           TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString));
  2536.           TokRec^.saved_state := tsFinish;
  2537.           TokRec^.state := tsEatws;
  2538.         end else
  2539.         if (v = '\') then
  2540.         begin
  2541.           TokRec^.saved_state := tsString;
  2542.           TokRec^.state := tsStringEscape;
  2543.         end else
  2544.         begin
  2545.           tok.pb.Append(@v, 1);
  2546.         end
  2547.       end;
  2548.  
  2549.     tsEvalProperty:
  2550.       begin
  2551.         if (TokRec^.current = nil) and (foCreatePath in options) then
  2552.         begin
  2553.           TokRec^.current := TSuperObject.Create(stObject);
  2554.           TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
  2555.         end else
  2556.         if not ObjectIsType(TokRec^.current, stObject) then
  2557.         begin
  2558.           tok.err := teEvalObject;
  2559.           goto out;
  2560.         end;
  2561.         tok.pb.Reset;
  2562.         TokRec^.state := tsIdentifier;
  2563.         goto redo_char;
  2564.       end;
  2565.  
  2566.     tsEvalArray:
  2567.       begin
  2568.         if (TokRec^.current = nil) and (foCreatePath in options) then
  2569.         begin
  2570.           TokRec^.current := TSuperObject.Create(stArray);
  2571.           TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
  2572.         end else
  2573.         if not ObjectIsType(TokRec^.current, stArray) then
  2574.         begin
  2575.           tok.err := teEvalArray;
  2576.           goto out;
  2577.         end;
  2578.         tok.pb.Reset;
  2579.         TokRec^.state := tsParamValue;
  2580.         goto redo_char;
  2581.       end;
  2582. {$IFDEF SUPER_METHOD}
  2583.     tsEvalMethod:
  2584.       begin
  2585.         if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
  2586.         begin
  2587.           tok.pb.Reset;
  2588.           TokRec^.obj := TSuperObject.Create(stArray);
  2589.           TokRec^.state := tsMethodValue;
  2590.           goto redo_char;
  2591.         end else
  2592.         begin
  2593.           tok.err := teEvalMethod;
  2594.           goto out;
  2595.         end;
  2596.       end;
  2597.  
  2598.     tsMethodValue:
  2599.       begin
  2600.         case v of
  2601.         ')':
  2602.             TokRec^.state := tsIdentifier;
  2603.         else
  2604.           if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
  2605.           begin
  2606.             tok.err := teDepth;
  2607.             goto out;
  2608.           end;
  2609.           inc(evalstack);
  2610.           TokRec^.state := tsMethodPut;
  2611.           inc(tok.depth);
  2612.           tok.ResetLevel(tok.depth);
  2613.           TokRec := @tok.stack[tok.depth];
  2614.           goto redo_char;
  2615.         end;
  2616.       end;
  2617.  
  2618.     tsMethodPut:
  2619.       begin
  2620.         TokRec^.obj.AsArray.Add(obj);
  2621.         case v of
  2622.           ',':
  2623.             begin
  2624.               tok.pb.Reset;
  2625.               TokRec^.saved_state := tsMethodValue;
  2626.               TokRec^.state := tsEatws;
  2627.             end;
  2628.           ')':
  2629.             begin
  2630.               if TokRec^.obj.AsArray.Length = 1 then
  2631.                 TokRec^.obj := TokRec^.obj.AsArray.GetO(0);
  2632.               dec(evalstack);
  2633.               tok.pb.Reset;
  2634.               TokRec^.saved_state := tsIdentifier;
  2635.               TokRec^.state := tsEatws;
  2636.             end;
  2637.         else
  2638.           tok.err := teEvalMethod;
  2639.           goto out;
  2640.         end;
  2641.       end;
  2642. {$ENDIF}
  2643.     tsParamValue:
  2644.       begin
  2645.         case v of
  2646.         ']':
  2647.             TokRec^.state := tsIdentifier;
  2648.         else
  2649.           if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
  2650.           begin
  2651.             tok.err := teDepth;
  2652.             goto out;
  2653.           end;
  2654.           inc(evalstack);
  2655.           TokRec^.state := tsParamPut;
  2656.           inc(tok.depth);
  2657.           tok.ResetLevel(tok.depth);
  2658.           TokRec := @tok.stack[tok.depth];
  2659.           goto redo_char;
  2660.         end;
  2661.       end;
  2662.  
  2663.     tsParamPut:
  2664.       begin
  2665.         dec(evalstack);
  2666.         TokRec^.obj := obj;
  2667.         tok.pb.Reset;
  2668.         TokRec^.saved_state := tsIdentifier;
  2669.         TokRec^.state := tsEatws;
  2670.         if v <> ']' then
  2671.         begin
  2672.           tok.err := teEvalArray;
  2673.           goto out;
  2674.         end;
  2675.       end;
  2676.  
  2677.     tsIdentifier:
  2678.       begin
  2679.         if (this = nil) then
  2680.         begin
  2681.           if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then
  2682.           begin
  2683.             if not strict then
  2684.             begin
  2685.               tok.pb.TrimRight;
  2686.               TokRec^.current := TSuperObject.Create(tok.pb.Fbuf);
  2687.               TokRec^.saved_state := tsFinish;
  2688.               TokRec^.state := tsEatws;
  2689.               goto redo_char;
  2690.             end else
  2691.             begin
  2692.               tok.err := teParseString;
  2693.               goto out;
  2694.             end;
  2695.           end else
  2696.           if (v = '\') then
  2697.           begin
  2698.             TokRec^.saved_state := tsIdentifier;
  2699.             TokRec^.state := tsStringEscape;
  2700.           end else
  2701.             tok.pb.Append(@v, 1);
  2702.         end else
  2703.         begin
  2704.          if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then
  2705.          begin
  2706.            TokRec^.gparent := TokRec^.parent;
  2707.            if TokRec^.current = nil then
  2708.              TokRec^.parent := this else
  2709.              TokRec^.parent := TokRec^.current;
  2710.  
  2711.              case ObjectGetType(TokRec^.parent) of
  2712.                stObject:
  2713.                  case v of
  2714.                    '.':
  2715.                      begin
  2716.                        TokRec^.state := tsEvalProperty;
  2717.                        if tok.pb.FBPos > 0 then
  2718.                          TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
  2719.                      end;
  2720.                    '[':
  2721.                      begin
  2722.                        TokRec^.state := tsEvalArray;
  2723.                        if tok.pb.FBPos > 0 then
  2724.                          TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
  2725.                      end;
  2726.                    '(':
  2727.                      begin
  2728.                        TokRec^.state := tsEvalMethod;
  2729.                        if tok.pb.FBPos > 0 then
  2730.                          TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
  2731.                      end;
  2732.                  else
  2733.                    if tok.pb.FBPos > 0 then
  2734.                      TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
  2735.                    if (foPutValue in options) and (evalstack = 0) then
  2736.                    begin
  2737.                      TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put);
  2738.                      TokRec^.current := put
  2739.                    end else
  2740.                    if (foDelete in options) and (evalstack = 0) then
  2741.                    begin
  2742.                      TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf);
  2743.                    end else
  2744.                    if (TokRec^.current = nil) and (foCreatePath in options) then
  2745.                    begin
  2746.                      TokRec^.current := TSuperObject.Create(dt);
  2747.                      TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current);
  2748.                    end;
  2749.                    TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
  2750.                    TokRec^.state := tsFinish;
  2751.                    goto redo_char;
  2752.                  end;
  2753.                stArray:
  2754.                  begin
  2755.                    if TokRec^.obj <> nil then
  2756.                    begin
  2757.                      if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then
  2758.                      begin
  2759.                        tok.err := teEvalInt;
  2760.                        TokRec^.obj := nil;
  2761.                        goto out;
  2762.                      end;
  2763.                      numi := TokRec^.obj.AsInteger;
  2764.                      TokRec^.obj := nil;
  2765.  
  2766.                      TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
  2767.                      case v of
  2768.                        '.':
  2769.                          if (TokRec^.current = nil) and (foCreatePath in options) then
  2770.                          begin
  2771.                            TokRec^.current := TSuperObject.Create(stObject);
  2772.                            TokRec^.parent.AsArray.PutO(numi, TokRec^.current);
  2773.                          end else
  2774.                          if (TokRec^.current = nil) then
  2775.                          begin
  2776.                            tok.err := teEvalObject;
  2777.                            goto out;
  2778.                          end;
  2779.                        '[':
  2780.                          begin
  2781.                            if (TokRec^.current = nil) and (foCreatePath in options) then
  2782.                            begin
  2783.                              TokRec^.current := TSuperObject.Create(stArray);
  2784.                              TokRec^.parent.AsArray.Add(TokRec^.current);
  2785.                            end else
  2786.                            if (TokRec^.current = nil) then
  2787.                            begin
  2788.                              tok.err := teEvalArray;
  2789.                              goto out;
  2790.                            end;
  2791.                            TokRec^.state := tsEvalArray;
  2792.                          end;
  2793.                        '(': TokRec^.state := tsEvalMethod;
  2794.                      else
  2795.                        if (foPutValue in options) and (evalstack = 0) then
  2796.                        begin
  2797.                          TokRec^.parent.AsArray.PutO(numi, put);
  2798.                          TokRec^.current := put;
  2799.                        end else
  2800.                        if (foDelete in options) and (evalstack = 0) then
  2801.                        begin
  2802.                          TokRec^.current := TokRec^.parent.AsArray.Delete(numi);
  2803.                        end else
  2804.                          TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
  2805.                        TokRec^.state := tsFinish;
  2806.                        goto redo_char
  2807.                      end;
  2808.                    end else
  2809.                    begin
  2810.                      case v of
  2811.                        '.':
  2812.                          begin
  2813.                            if (foPutValue in options) then
  2814.                            begin
  2815.                              TokRec^.current := TSuperObject.Create(stObject);
  2816.                              TokRec^.parent.AsArray.Add(TokRec^.current);
  2817.                            end else
  2818.                              TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
  2819.                          end;
  2820.                        '[':
  2821.                          begin
  2822.                            if (foPutValue in options) then
  2823.                            begin
  2824.                              TokRec^.current := TSuperObject.Create(stArray);
  2825.                              TokRec^.parent.AsArray.Add(TokRec^.current);
  2826.                            end else
  2827.                              TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
  2828.                            TokRec^.state := tsEvalArray;
  2829.                          end;
  2830.                        '(':
  2831.                          begin
  2832.                            if not (foPutValue in options) then
  2833.                              TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else
  2834.                              TokRec^.current := nil;
  2835.  
  2836.                            TokRec^.state := tsEvalMethod;
  2837.                          end;
  2838.                      else
  2839.                        if (foPutValue in options) and (evalstack = 0) then
  2840.                        begin
  2841.                          TokRec^.parent.AsArray.Add(put);
  2842.                          TokRec^.current := put;
  2843.                        end else
  2844.                          if tok.pb.FBPos = 0 then
  2845.                            TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
  2846.                        TokRec^.state := tsFinish;
  2847.                        goto redo_char
  2848.                      end;
  2849.                    end;
  2850.                  end;
  2851. {$IFDEF SUPER_METHOD}
  2852.                stMethod:
  2853.                  case v of
  2854.                    '.':
  2855.                      begin
  2856.                        TokRec^.current := nil;
  2857.                        sm := TokRec^.parent.AsMethod;
  2858.                        sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
  2859.                        TokRec^.obj := nil;
  2860.                      end;
  2861.                    '[':
  2862.                      begin
  2863.                        TokRec^.current := nil;
  2864.                        sm := TokRec^.parent.AsMethod;
  2865.                        sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
  2866.                        TokRec^.state := tsEvalArray;
  2867.                        TokRec^.obj := nil;
  2868.                      end;
  2869.                    '(':
  2870.                      begin
  2871.                        TokRec^.current := nil;
  2872.                        sm := TokRec^.parent.AsMethod;
  2873.                        sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
  2874.                        TokRec^.state := tsEvalMethod;
  2875.                        TokRec^.obj := nil;
  2876.                      end;
  2877.                  else
  2878.                    if not (foPutValue in options) or (evalstack > 0) then
  2879.                    begin
  2880.                      TokRec^.current := nil;
  2881.                      sm := TokRec^.parent.AsMethod;
  2882.                      sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
  2883.                      TokRec^.obj := nil;
  2884.                      TokRec^.state := tsFinish;
  2885.                      goto redo_char
  2886.                    end else
  2887.                    begin
  2888.                      tok.err := teEvalMethod;
  2889.                      TokRec^.obj := nil;
  2890.                      goto out;
  2891.                    end;
  2892.                  end;
  2893. {$ENDIF}
  2894.              end;
  2895.           end else
  2896.             tok.pb.Append(@v, 1);
  2897.         end;
  2898.       end;
  2899.  
  2900.     tsStringEscape:
  2901.       case v of
  2902.       'b',
  2903.       'n',
  2904.       'r',
  2905.       't',
  2906.       'f':
  2907.         begin
  2908.           if(v = 'b') then tok.pb.Append(TOK_BS, 1)
  2909.           else if(v = 'n') then tok.pb.Append(TOK_LF, 1)
  2910.           else if(v = 'r') then tok.pb.Append(TOK_CR, 1)
  2911.           else if(v = 't') then tok.pb.Append(TOK_TAB, 1)
  2912.           else if(v = 'f') then tok.pb.Append(TOK_FF, 1);
  2913.           TokRec^.state := TokRec^.saved_state;
  2914.         end;
  2915.       'u':
  2916.         begin
  2917.           tok.ucs_char := 0;
  2918.           tok.st_pos := 0;
  2919.           TokRec^.state := tsEscapeUnicode;
  2920.         end;
  2921.       'x':
  2922.         begin
  2923.           tok.ucs_char := 0;
  2924.           tok.st_pos := 0;
  2925.           TokRec^.state := tsEscapeHexadecimal;
  2926.         end
  2927.       else
  2928.         tok.pb.Append(@v, 1);
  2929.         TokRec^.state := TokRec^.saved_state;
  2930.       end;
  2931.  
  2932.     tsEscapeUnicode:
  2933.       begin
  2934.         if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
  2935.         begin
  2936.           inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4)));
  2937.           inc(tok.st_pos);
  2938.           if (tok.st_pos = 4) then
  2939.           begin
  2940.             tok.pb.Append(@tok.ucs_char, 1);
  2941.             TokRec^.state := TokRec^.saved_state;
  2942.           end
  2943.         end else
  2944.         begin
  2945.           tok.err := teParseString;
  2946.           goto out;
  2947.         end
  2948.       end;
  2949.     tsEscapeHexadecimal:
  2950.       begin
  2951.         if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
  2952.         begin
  2953.           inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4)));
  2954.           inc(tok.st_pos);
  2955.           if (tok.st_pos = 2) then
  2956.           begin
  2957.             tok.pb.Append(@tok.ucs_char, 1);
  2958.             TokRec^.state := TokRec^.saved_state;
  2959.           end
  2960.         end else
  2961.         begin
  2962.           tok.err := teParseString;
  2963.           goto out;
  2964.         end
  2965.       end;
  2966.     tsBoolean:
  2967.       begin
  2968.         tok.pb.Append(@v, 1);
  2969.         if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
  2970.         begin
  2971.           if (tok.st_pos = 4) then
  2972.           if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
  2973.             TokRec^.state := tsIdentifier else
  2974.           begin
  2975.             TokRec^.current := TSuperObject.Create(true);
  2976.             TokRec^.saved_state := tsFinish;
  2977.             TokRec^.state := tsEatws;
  2978.             goto redo_char;
  2979.           end
  2980.         end else
  2981.         if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then
  2982.         begin
  2983.           if (tok.st_pos = 5) then
  2984.           if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
  2985.             TokRec^.state := tsIdentifier else
  2986.           begin
  2987.             TokRec^.current := TSuperObject.Create(false);
  2988.             TokRec^.saved_state := tsFinish;
  2989.             TokRec^.state := tsEatws;
  2990.             goto redo_char;
  2991.           end
  2992.         end else
  2993.         begin
  2994.           TokRec^.state := tsIdentifier;
  2995.           tok.pb.FBuf[tok.st_pos] := #0;
  2996.           dec(tok.pb.FBPos);
  2997.           goto redo_char;
  2998.         end;
  2999.         inc(tok.st_pos);
  3000.       end;
  3001.  
  3002.     tsNumber:
  3003.       begin
  3004.         if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then
  3005.         begin
  3006.           tok.pb.Append(@v, 1);
  3007.           if (SOIChar(v) < 256) then
  3008.           case v of
  3009.           '.': begin
  3010.                  tok.is_double := 1;
  3011.                  tok.floatcount := 0;
  3012.                end;
  3013.           'e','E':
  3014.             begin
  3015.               tok.is_double := 1;
  3016.               tok.floatcount := -1;
  3017.             end;
  3018.           '0'..'9':
  3019.             begin
  3020.  
  3021.               if (tok.is_double = 1) and (tok.floatcount >= 0) then
  3022.               begin
  3023.                 inc(tok.floatcount);
  3024.                 if tok.floatcount > 4 then
  3025.                   tok.floatcount := -1;
  3026.               end;
  3027.             end;
  3028.           end;
  3029.         end else
  3030.         begin
  3031.           if (tok.is_double = 0) then
  3032.           begin
  3033.             val(tok.pb.FBuf, numi, code);
  3034.             if ObjectIsType(this, stArray) then
  3035.             begin
  3036.               if (foPutValue in options) and (evalstack = 0) then
  3037.               begin
  3038.                 this.AsArray.PutO(numi, put);
  3039.                 TokRec^.current := put;
  3040.               end else
  3041.               if (foDelete in options) and (evalstack = 0) then
  3042.                 TokRec^.current := this.AsArray.Delete(numi) else
  3043.                 TokRec^.current := this.AsArray.GetO(numi);
  3044.             end else
  3045.               TokRec^.current := TSuperObject.Create(numi);
  3046.  
  3047.           end else
  3048.           if (tok.is_double <> 0) then
  3049.           begin
  3050.             if tok.floatcount >= 0 then
  3051.             begin
  3052.               p := tok.pb.FBuf;
  3053.               while p^ <> '.' do inc(p);
  3054.               for code := 0 to tok.floatcount - 1 do
  3055.               begin
  3056.                 p^ := p[1];
  3057.                 inc(p);
  3058.               end;
  3059.               p^ := #0;
  3060.               val(tok.pb.FBuf, numi, code);
  3061.               case tok.floatcount of
  3062.                 0: numi := numi * 10000;
  3063.                 1: numi := numi * 1000;
  3064.                 2: numi := numi * 100;
  3065.                 3: numi := numi * 10;
  3066.               end;
  3067.               TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^);
  3068.             end else
  3069.             begin
  3070.               val(tok.pb.FBuf, numd, code);
  3071.               TokRec^.current := TSuperObject.Create(numd);
  3072.             end;
  3073.           end else
  3074.           begin
  3075.             tok.err := teParseNumber;
  3076.             goto out;
  3077.           end;
  3078.           TokRec^.saved_state := tsFinish;
  3079.           TokRec^.state := tsEatws;
  3080.           goto redo_char;
  3081.         end
  3082.       end;
  3083.  
  3084.     tsArray:
  3085.       begin
  3086.         if (v = ']') then
  3087.         begin
  3088.           TokRec^.saved_state := tsFinish;
  3089.           TokRec^.state := tsEatws;
  3090.         end else
  3091.         begin
  3092.           if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
  3093.           begin
  3094.             tok.err := teDepth;
  3095.             goto out;
  3096.           end;
  3097.           TokRec^.state := tsArrayAdd;
  3098.           inc(tok.depth);
  3099.           tok.ResetLevel(tok.depth);
  3100.           TokRec := @tok.stack[tok.depth];
  3101.           goto redo_char;
  3102.         end
  3103.       end;
  3104.  
  3105.     tsArrayAdd:
  3106.       begin
  3107.         TokRec^.current.AsArray.Add(obj);
  3108.         TokRec^.saved_state := tsArraySep;
  3109.         TokRec^.state := tsEatws;
  3110.         goto redo_char;
  3111.       end;
  3112.  
  3113.     tsArraySep:
  3114.       begin
  3115.         if (v = ']') then
  3116.         begin
  3117.           TokRec^.saved_state := tsFinish;
  3118.           TokRec^.state := tsEatws;
  3119.         end else
  3120.         if (v = ',') then
  3121.         begin
  3122.           TokRec^.saved_state := tsArray;
  3123.           TokRec^.state := tsEatws;
  3124.         end else
  3125.         begin
  3126.           tok.err := teParseArray;
  3127.           goto out;
  3128.         end
  3129.       end;
  3130.  
  3131.     tsObjectFieldStart:
  3132.       begin
  3133.         if (v = '}') then
  3134.         begin
  3135.           TokRec^.saved_state := tsFinish;
  3136.           TokRec^.state := tsEatws;
  3137.         end else
  3138.         if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then
  3139.         begin
  3140.           tok.quote_char := v;
  3141.           tok.pb.Reset;
  3142.           TokRec^.state := tsObjectField;
  3143.         end else
  3144.         if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then
  3145.         begin
  3146.           TokRec^.state := tsObjectUnquotedField;
  3147.           tok.pb.Reset;
  3148.           goto redo_char;
  3149.         end else
  3150.         begin
  3151.           tok.err := teParseObjectKeyName;
  3152.           goto out;
  3153.         end
  3154.       end;
  3155.  
  3156.     tsObjectField:
  3157.       begin
  3158.         if (v = tok.quote_char) then
  3159.         begin
  3160.           TokRec^.field_name := tok.pb.FBuf;
  3161.           TokRec^.saved_state := tsObjectFieldEnd;
  3162.           TokRec^.state := tsEatws;
  3163.         end else
  3164.         if (v = '\') then
  3165.         begin
  3166.           TokRec^.saved_state := tsObjectField;
  3167.           TokRec^.state := tsStringEscape;
  3168.         end else
  3169.         begin
  3170.           tok.pb.Append(@v, 1);
  3171.         end
  3172.       end;
  3173.  
  3174.     tsObjectUnquotedField:
  3175.       begin
  3176.         if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then
  3177.         begin
  3178.           TokRec^.field_name := tok.pb.FBuf;
  3179.           TokRec^.saved_state := tsObjectFieldEnd;
  3180.           TokRec^.state := tsEatws;
  3181.           goto redo_char;
  3182.         end else
  3183.         if (v = '\') then
  3184.         begin
  3185.           TokRec^.saved_state := tsObjectUnquotedField;
  3186.           TokRec^.state := tsStringEscape;
  3187.         end else
  3188.           tok.pb.Append(@v, 1);
  3189.       end;
  3190.  
  3191.     tsObjectFieldEnd:
  3192.       begin
  3193.         if (v = ':') then
  3194.         begin
  3195.           TokRec^.saved_state := tsObjectValue;
  3196.           TokRec^.state := tsEatws;
  3197.         end else
  3198.         begin
  3199.           tok.err := teParseObjectKeySep;
  3200.           goto out;
  3201.         end
  3202.       end;
  3203.  
  3204.     tsObjectValue:
  3205.       begin
  3206.         if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
  3207.         begin
  3208.           tok.err := teDepth;
  3209.           goto out;
  3210.         end;
  3211.         TokRec^.state := tsObjectValueAdd;
  3212.         inc(tok.depth);
  3213.         tok.ResetLevel(tok.depth);
  3214.         TokRec := @tok.stack[tok.depth];
  3215.         goto redo_char;
  3216.       end;
  3217.  
  3218.     tsObjectValueAdd:
  3219.       begin
  3220.         TokRec^.current.AsObject.PutO(TokRec^.field_name, obj);
  3221.         TokRec^.field_name := '';
  3222.         TokRec^.saved_state := tsObjectSep;
  3223.         TokRec^.state := tsEatws;
  3224.         goto redo_char;
  3225.       end;
  3226.  
  3227.     tsObjectSep:
  3228.       begin
  3229.         if (v = '}') then
  3230.         begin
  3231.           TokRec^.saved_state := tsFinish;
  3232.           TokRec^.state := tsEatws;
  3233.         end else
  3234.         if (v = ',') then
  3235.         begin
  3236.           TokRec^.saved_state := tsObjectFieldStart;
  3237.           TokRec^.state := tsEatws;
  3238.         end else
  3239.         begin
  3240.           tok.err := teParseObjectValueSep;
  3241.           goto out;
  3242.         end
  3243.       end;
  3244.     end;
  3245.     inc(str);
  3246.     inc(tok.char_offset);
  3247.   until v = #0;
  3248.  
  3249.   if(TokRec^.state <> tsFinish) and
  3250.      (TokRec^.saved_state <> tsFinish) then
  3251.     tok.err := teParseEof;
  3252.  
  3253.  out:
  3254.   if(tok.err in [teSuccess]) then
  3255.   begin
  3256. {$IFDEF SUPER_METHOD}
  3257.     if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
  3258.     begin
  3259.       sm := TokRec^.current.AsMethod;
  3260.       sm(TokRec^.parent, put, Result);
  3261.     end else
  3262. {$ENDIF}
  3263.     Result := TokRec^.current;
  3264.   end else
  3265.     Result := nil;
  3266. end;
  3267.  
  3268. procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject);
  3269. begin
  3270.   ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value);
  3271. end;
  3272.  
  3273. procedure TSuperObject.PutB(const path: SOString; Value: Boolean);
  3274. begin
  3275.   ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
  3276. end;
  3277.  
  3278. procedure TSuperObject.PutD(const path: SOString; Value: Double);
  3279. begin
  3280.   ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
  3281. end;
  3282.  
  3283. procedure TSuperObject.PutC(const path: SOString; Value: Currency);
  3284. begin
  3285.   ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value));
  3286. end;
  3287.  
  3288. procedure TSuperObject.PutI(const path: SOString; Value: SuperInt);
  3289. begin
  3290.   ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
  3291. end;
  3292.  
  3293. procedure TSuperObject.PutS(const path: SOString; const Value: SOString);
  3294. begin
  3295.   ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
  3296. end;
  3297.  
  3298. function TSuperObject.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  3299. begin
  3300.   if GetInterface(IID, Obj) then
  3301.     Result := 0
  3302.   else
  3303.     Result := E_NOINTERFACE;
  3304. end;
  3305.  
  3306. function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer;
  3307. var
  3308.   pb: TSuperWriterStream;
  3309. begin
  3310.   if escape then
  3311.     pb := TSuperAnsiWriterStream.Create(stream) else
  3312.     pb := TSuperUnicodeWriterStream.Create(stream);
  3313.  
  3314.   if(Write(pb, indent, escape, 0) < 0) then
  3315.   begin
  3316.     pb.Reset;
  3317.     pb.Free;
  3318.     Result := 0;
  3319.     Exit;
  3320.   end;
  3321.   Result := stream.Size;
  3322.   pb.Free;
  3323. end;
  3324.  
  3325. function TSuperObject.CalcSize(indent, escape: boolean): integer;
  3326. var
  3327.   pb: TSuperWriterFake;
  3328. begin
  3329.   pb := TSuperWriterFake.Create;
  3330.   if(Write(pb, indent, escape, 0) < 0) then
  3331.   begin
  3332.     pb.Free;
  3333.     Result := 0;
  3334.     Exit;
  3335.   end;
  3336.   Result := pb.FSize;
  3337.   pb.Free;
  3338. end;
  3339.  
  3340. function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer;
  3341. var
  3342.   pb: TSuperWriterSock;
  3343. begin
  3344.   pb := TSuperWriterSock.Create(socket);
  3345.   if(Write(pb, indent, escape, 0) < 0) then
  3346.   begin
  3347.     pb.Free;
  3348.     Result := 0;
  3349.     Exit;
  3350.   end;
  3351.   Result := pb.FSize;
  3352.   pb.Free;
  3353. end;
  3354.  
  3355. constructor TSuperObject.Create(const s: SOString);
  3356. begin
  3357.   Create(stString);
  3358.   FOString := s;
  3359. end;
  3360.  
  3361. procedure TSuperObject.Clear(all: boolean);
  3362. begin
  3363.   if FProcessing then exit;
  3364.   FProcessing := true;
  3365.   try
  3366.     case FDataType of
  3367.       stBoolean: FO.c_boolean := false;
  3368.       stDouble: FO.c_double := 0.0;
  3369.       stCurrency: FO.c_currency := 0.0;
  3370.       stInt: FO.c_int := 0;
  3371.       stObject: FO.c_object.Clear(all);
  3372.       stArray: FO.c_array.Clear(all);
  3373.       stString: FOString := '';
  3374. {$IFDEF SUPER_METHOD}
  3375.       stMethod: FO.c_method := nil;
  3376. {$ENDIF}
  3377.     end;
  3378.   finally
  3379.     FProcessing := false;
  3380.   end;
  3381. end;
  3382.  
  3383. procedure TSuperObject.Pack(all: boolean = false);
  3384. begin
  3385.   if FProcessing then exit;
  3386.   FProcessing := true;
  3387.   try
  3388.     case FDataType of
  3389.       stObject: FO.c_object.Pack(all);
  3390.       stArray: FO.c_array.Pack(all);
  3391.     end;
  3392.   finally
  3393.     FProcessing := false;
  3394.   end;
  3395. end;
  3396.  
  3397. function TSuperObject.GetN(const path: SOString): ISuperObject;
  3398. begin
  3399.   Result := ParseString(PSOChar(path), False, true, self);
  3400.   if Result = nil then
  3401.     Result := TSuperObject.Create(stNull);
  3402. end;
  3403.  
  3404. procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject);
  3405. begin
  3406.   if Value = nil then
  3407.     ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else
  3408.     ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value);
  3409. end;
  3410.  
  3411. function TSuperObject.Delete(const path: SOString): ISuperObject;
  3412. begin
  3413.   Result := ParseString(PSOChar(path), False, true, self, [foDelete]);
  3414. end;
  3415.  
  3416. function TSuperObject.Clone: ISuperObject;
  3417. var
  3418.   ite: TSuperObjectIter;
  3419.   arr: TSuperArray;
  3420.   j: integer;
  3421. begin
  3422.   case FDataType of
  3423.     stBoolean: Result := TSuperObject.Create(FO.c_boolean);
  3424.     stDouble: Result := TSuperObject.Create(FO.c_double);
  3425.     stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency);
  3426.     stInt: Result := TSuperObject.Create(FO.c_int);
  3427.     stString: Result := TSuperObject.Create(FOString);
  3428. {$IFDEF SUPER_METHOD}
  3429.     stMethod: Result := TSuperObject.Create(FO.c_method);
  3430. {$ENDIF}
  3431.     stObject:
  3432.       begin
  3433.         Result := TSuperObject.Create(stObject);
  3434.         if ObjectFindFirst(self, ite) then
  3435.         with Result.AsObject do
  3436.         repeat
  3437.           PutO(ite.key, ite.val.Clone);
  3438.         until not ObjectFindNext(ite);
  3439.         ObjectFindClose(ite);
  3440.       end;
  3441.     stArray:
  3442.       begin
  3443.         Result := TSuperObject.Create(stArray);
  3444.         arr := AsArray;
  3445.         with Result.AsArray do
  3446.         for j := 0 to arr.Length - 1 do
  3447.           Add(arr.GetO(j).Clone);
  3448.       end;
  3449.   else
  3450.     Result := nil;
  3451.   end;
  3452. end;
  3453.  
  3454. procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean);
  3455. var
  3456.   prop1, prop2: ISuperObject;
  3457.   ite: TSuperObjectIter;
  3458.   arr: TSuperArray;
  3459.   j: integer;
  3460. begin
  3461.   if ObjectIsType(obj, FDataType) then
  3462.   case FDataType of
  3463.     stBoolean: FO.c_boolean := obj.AsBoolean;
  3464.     stDouble: FO.c_double := obj.AsDouble;
  3465.     stCurrency: FO.c_currency := obj.AsCurrency;
  3466.     stInt: FO.c_int := obj.AsInteger;
  3467.     stString: FOString := obj.AsString;
  3468. {$IFDEF SUPER_METHOD}
  3469.     stMethod: FO.c_method := obj.AsMethod;
  3470. {$ENDIF}
  3471.     stObject:
  3472.       begin
  3473.         if ObjectFindFirst(obj, ite) then
  3474.         with FO.c_object do
  3475.         repeat
  3476.           prop1 := FO.c_object.GetO(ite.key);
  3477.           if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then
  3478.             prop1.Merge(ite.val) else
  3479.             if reference then
  3480.               PutO(ite.key, ite.val) else
  3481.               PutO(ite.key, ite.val.Clone);
  3482.         until not ObjectFindNext(ite);
  3483.         ObjectFindClose(ite);
  3484.       end;
  3485.     stArray:
  3486.       begin
  3487.         arr := obj.AsArray;
  3488.         with FO.c_array do
  3489.         for j := 0 to arr.Length - 1 do
  3490.         begin
  3491.           prop1 := GetO(j);
  3492.           prop2 := arr.GetO(j);
  3493.           if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then
  3494.             prop1.Merge(prop2) else
  3495.             if reference then
  3496.               PutO(j, prop2) else
  3497.               PutO(j, prop2.Clone);
  3498.         end;
  3499.       end;
  3500.   end;
  3501. end;
  3502.  
  3503. procedure TSuperObject.Merge(const str: SOString);
  3504. begin
  3505.   Merge(TSuperObject.ParseString(PSOChar(str), False), true);
  3506. end;
  3507.  
  3508. class function TSuperObject.NewInstance: TObject;
  3509. begin
  3510.   Result := inherited NewInstance;
  3511.   TSuperObject(Result).FRefCount := 1;
  3512. end;
  3513.  
  3514. function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
  3515. begin
  3516.   Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType);
  3517. end;
  3518.  
  3519. function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString;
  3520. var
  3521.   p1, p2: PSOChar;
  3522. begin
  3523.   Result := '';
  3524.   p2 := PSOChar(str);
  3525.   p1 := p2;
  3526.   while true do
  3527.     if p2^ = BeginSep then
  3528.       begin
  3529.         if p2 > p1 then
  3530.           Result := Result + Copy(p1, 0, p2-p1);
  3531.         inc(p2);
  3532.         p1 := p2;
  3533.         while true do
  3534.           if p2^ = EndSep then Break else
  3535.           if p2^ = #0     then Exit else
  3536.             inc(p2);
  3537.         Result := Result + GetS(copy(p1, 0, p2-p1));
  3538.         inc(p2);
  3539.         p1 := p2;
  3540.       end
  3541.     else if p2^ = #0 then
  3542.       begin
  3543.         if p2 > p1 then
  3544.           Result := Result + Copy(p1, 0, p2-p1);
  3545.         Break;
  3546.       end else
  3547.         inc(p2);
  3548. end;
  3549.  
  3550. function TSuperObject.GetO(const path: SOString): ISuperObject;
  3551. begin
  3552.   Result := ParseString(PSOChar(path), False, True, Self);
  3553. end;
  3554.  
  3555. function TSuperObject.GetA(const path: SOString): TSuperArray;
  3556. var
  3557.   obj: ISuperObject;
  3558. begin
  3559.   obj := ParseString(PSOChar(path), False, True, Self);
  3560.   if obj <> nil then
  3561.     Result := obj.AsArray else
  3562.     Result := nil;
  3563. end;
  3564.  
  3565. function TSuperObject.GetB(const path: SOString): Boolean;
  3566. var
  3567.   obj: ISuperObject;
  3568. begin
  3569.   obj := GetO(path);
  3570.   if obj <> nil then
  3571.     Result := obj.AsBoolean else
  3572.     Result := false;
  3573. end;
  3574.  
  3575. function TSuperObject.GetD(const path: SOString): Double;
  3576. var
  3577.   obj: ISuperObject;
  3578. begin
  3579.   obj := GetO(path);
  3580.   if obj <> nil then
  3581.     Result := obj.AsDouble else
  3582.     Result := 0.0;
  3583. end;
  3584.  
  3585. function TSuperObject.GetC(const path: SOString): Currency;
  3586. var
  3587.   obj: ISuperObject;
  3588. begin
  3589.   obj := GetO(path);
  3590.   if obj <> nil then
  3591.     Result := obj.AsCurrency else
  3592.     Result := 0.0;
  3593. end;
  3594.  
  3595. function TSuperObject.GetI(const path: SOString): SuperInt;
  3596. var
  3597.   obj: ISuperObject;
  3598. begin
  3599.   obj := GetO(path);
  3600.   if obj <> nil then
  3601.     Result := obj.AsInteger else
  3602.     Result := 0;
  3603. end;
  3604.  
  3605. function TSuperObject.GetDataPtr: Pointer;
  3606. begin
  3607.   Result := FDataPtr;
  3608. end;
  3609.  
  3610. function TSuperObject.GetDataType: TSuperType;
  3611. begin
  3612.   Result := FDataType
  3613. end;
  3614.  
  3615. function TSuperObject.GetS(const path: SOString): SOString;
  3616. var
  3617.   obj: ISuperObject;
  3618. begin
  3619.   obj := GetO(path);
  3620.   if obj <> nil then
  3621.     Result := obj.AsString else
  3622.     Result := '';
  3623. end;
  3624.  
  3625. function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer;
  3626. var
  3627.   stream: TFileStream;
  3628. begin
  3629.   stream := TFileStream.Create(FileName, fmCreate);
  3630.   try
  3631.     Result := SaveTo(stream, indent, escape);
  3632.   finally
  3633.     stream.Free;
  3634.   end;
  3635. end;
  3636.  
  3637. function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
  3638. begin
  3639.   Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender);
  3640. end;
  3641.  
  3642. function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
  3643. type
  3644.   TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool,
  3645.                dtMap, dtSeq, dtScalar, dtAny);
  3646. var
  3647.   datatypes: ISuperObject;
  3648.   names: ISuperObject;
  3649.  
  3650.   function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject;
  3651.   var
  3652.     o: ISuperObject;
  3653.     e: TSuperAvlEntry;
  3654.   begin
  3655.     o := p[prop];
  3656.     if o <> nil then
  3657.       result := o else
  3658.       begin
  3659.         o := p['inherit'];
  3660.         if (o <> nil) and ObjectIsType(o, stString) then
  3661.           begin
  3662.             e := names.AsObject.Search(o.AsString);
  3663.             if (e <> nil) then
  3664.               Result := FindInheritedProperty(prop, e.Value) else
  3665.               Result := nil;
  3666.           end else
  3667.             Result := nil;
  3668.       end;
  3669.   end;
  3670.  
  3671.   function FindDataType(o: ISuperObject): TDataType;
  3672.   var
  3673.     e: TSuperAvlEntry;
  3674.     obj: ISuperObject;
  3675.   begin
  3676.     obj := FindInheritedProperty('type', o);
  3677.     if obj <> nil then
  3678.     begin
  3679.       e := datatypes.AsObject.Search(obj.AsString);
  3680.       if  e <> nil then
  3681.         Result := TDataType(e.Value.AsInteger) else
  3682.         Result := dtUnknown;
  3683.     end else
  3684.       Result := dtUnknown;
  3685.   end;
  3686.  
  3687.   procedure GetNames(o: ISuperObject);
  3688.   var
  3689.     obj: ISuperObject;
  3690.     f: TSuperObjectIter;
  3691.   begin
  3692.     obj := o['name'];
  3693.     if ObjectIsType(obj, stString) then
  3694.       names[obj.AsString] := o;
  3695.  
  3696.     case FindDataType(o) of
  3697.       dtMap:
  3698.         begin
  3699.           obj := o['mapping'];
  3700.           if ObjectIsType(obj, stObject) then
  3701.           begin
  3702.             if ObjectFindFirst(obj, f) then
  3703.             repeat
  3704.               if ObjectIsType(f.val, stObject) then
  3705.                 GetNames(f.val);
  3706.             until not ObjectFindNext(f);
  3707.             ObjectFindClose(f);
  3708.           end;
  3709.         end;
  3710.       dtSeq:
  3711.         begin
  3712.           obj := o['sequence'];
  3713.           if ObjectIsType(obj, stObject) then
  3714.             GetNames(obj);
  3715.         end;
  3716.     end;
  3717.   end;
  3718.  
  3719.   function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject;
  3720.   var
  3721.     o: ISuperObject;
  3722.     e: TSuperAvlEntry;
  3723.   begin
  3724.     o := p['mapping'];
  3725.     if ObjectIsType(o, stObject) then
  3726.     begin
  3727.       o := o.AsObject.GetO(prop);
  3728.       if o <> nil then
  3729.       begin
  3730.         Result := o;
  3731.         Exit;
  3732.       end;
  3733.     end;
  3734.  
  3735.     o := p['inherit'];
  3736.     if ObjectIsType(o, stString) then
  3737.     begin
  3738.       e := names.AsObject.Search(o.AsString);
  3739.       if (e <> nil) then
  3740.         Result := FindInheritedField(prop, e.Value) else
  3741.         Result := nil;
  3742.     end else
  3743.       Result := nil;
  3744.   end;
  3745.  
  3746.   function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean;
  3747.   var
  3748.    o: ISuperObject;
  3749.    e: TSuperAvlEntry;
  3750.    j: TSuperAvlIterator;
  3751.   begin
  3752.     Result := true;
  3753.     o := p['mapping'];
  3754.     if ObjectIsType(o, stObject) then
  3755.     begin
  3756.       j := TSuperAvlIterator.Create(o.AsObject);
  3757.       try
  3758.         j.First;
  3759.         e := j.GetIter;
  3760.         while e <> nil do
  3761.         begin
  3762.           if obj.AsObject.Search(e.Name) = nil then
  3763.           begin
  3764.             Result := False;
  3765.             if assigned(callback) then
  3766.               callback(sender, veFieldNotFound, name + '.' + e.Name);
  3767.           end;
  3768.           j.Next;
  3769.           e := j.GetIter;
  3770.         end;
  3771.  
  3772.       finally
  3773.         j.Free;
  3774.       end;
  3775.     end;
  3776.  
  3777.     o := p['inherit'];
  3778.     if ObjectIsType(o, stString) then
  3779.     begin
  3780.       e := names.AsObject.Search(o.AsString);
  3781.       if (e <> nil) then
  3782.         Result := InheritedFieldExist(obj, e.Value, name) and Result;
  3783.     end;
  3784.   end;
  3785.  
  3786.   function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean;
  3787.   var
  3788.     o: ISuperObject;
  3789.   begin
  3790.     o := FindInheritedProperty(f, p);
  3791.     case ObjectGetType(o) of
  3792.       stBoolean: Result := o.AsBoolean;
  3793.       stNull: Result := Default;
  3794.     else
  3795.       Result := default;
  3796.       if assigned(callback) then
  3797.         callback(sender, veRuleMalformated, f);
  3798.     end;
  3799.   end;
  3800.  
  3801.   procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject);
  3802.   var
  3803.    o: ISuperObject;
  3804.    e: TSuperAvlEntry;
  3805.    i: TSuperAvlIterator;
  3806.   begin
  3807.     Result := true;
  3808.     o := p['mapping'];
  3809.     if ObjectIsType(o, stObject) then
  3810.     begin
  3811.       i := TSuperAvlIterator.Create(o.AsObject);
  3812.       try
  3813.         i.First;
  3814.         e := i.GetIter;
  3815.         while e <> nil do
  3816.         begin
  3817.           if list.AsObject.Search(e.Name) = nil then
  3818.             list[e.Name] := e.Value;
  3819.           i.Next;
  3820.           e := i.GetIter;
  3821.         end;
  3822.  
  3823.       finally
  3824.         i.Free;
  3825.       end;
  3826.     end;
  3827.  
  3828.     o := p['inherit'];
  3829.     if ObjectIsType(o, stString) then
  3830.     begin
  3831.       e := names.AsObject.Search(o.AsString);
  3832.       if (e <> nil) then
  3833.         GetInheritedFieldList(list, e.Value);
  3834.     end;
  3835.   end;
  3836.  
  3837.   function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean;
  3838.   var
  3839.     enum: ISuperObject;
  3840.     i: integer;
  3841.   begin
  3842.     Result := false;
  3843.     enum := FindInheritedProperty('enum', p);
  3844.     case ObjectGetType(enum) of
  3845.       stArray:
  3846.         for i := 0 to enum.AsArray.Length - 1 do
  3847.           if (o.AsString = enum.AsArray[i].AsString) then
  3848.           begin
  3849.             Result := true;
  3850.             exit;
  3851.           end;
  3852.       stNull: Result := true;
  3853.     else
  3854.       Result := false;
  3855.       if assigned(callback) then
  3856.         callback(sender, veRuleMalformated, '');
  3857.       Exit;
  3858.     end;
  3859.  
  3860.     if (not Result) and assigned(callback) then
  3861.       callback(sender, veValueNotInEnum, name);
  3862.   end;
  3863.  
  3864.   function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean;
  3865.   var
  3866.     length, o: ISuperObject;
  3867.   begin
  3868.     result := true;
  3869.     length := FindInheritedProperty('length', p);
  3870.     case ObjectGetType(length) of
  3871.       stObject:
  3872.         begin
  3873.           o := length.AsObject.GetO('min');
  3874.           if (o <> nil) and (o.AsInteger > len) then
  3875.           begin
  3876.             Result := false;
  3877.             if assigned(callback) then
  3878.               callback(sender, veInvalidLength, objpath);
  3879.           end;
  3880.           o := length.AsObject.GetO('max');
  3881.           if (o <> nil) and (o.AsInteger < len) then
  3882.           begin
  3883.             Result := false;
  3884.             if assigned(callback) then
  3885.               callback(sender, veInvalidLength, objpath);
  3886.           end;
  3887.           o := length.AsObject.GetO('minex');
  3888.           if (o <> nil) and (o.AsInteger >= len) then
  3889.           begin
  3890.             Result := false;
  3891.             if assigned(callback) then
  3892.               callback(sender, veInvalidLength, objpath);
  3893.           end;
  3894.           o := length.AsObject.GetO('maxex');
  3895.           if (o <> nil) and (o.AsInteger <= len) then
  3896.           begin
  3897.             Result := false;
  3898.             if assigned(callback) then
  3899.               callback(sender, veInvalidLength, objpath);
  3900.           end;
  3901.         end;
  3902.       stNull: ;
  3903.     else
  3904.       Result := false;
  3905.       if assigned(callback) then
  3906.         callback(sender, veRuleMalformated, '');
  3907.     end;
  3908.   end;
  3909.  
  3910.   function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean;
  3911.   var
  3912.     length, o: ISuperObject;
  3913.   begin
  3914.     result := true;
  3915.     length := FindInheritedProperty('range', p);
  3916.     case ObjectGetType(length) of
  3917.       stObject:
  3918.         begin
  3919.           o := length.AsObject.GetO('min');
  3920.           if (o <> nil) and (o.Compare(obj) = cpGreat) then
  3921.           begin
  3922.             Result := false;
  3923.             if assigned(callback) then
  3924.               callback(sender, veInvalidRange, objpath);
  3925.           end;
  3926.           o := length.AsObject.GetO('max');
  3927.           if (o <> nil) and (o.Compare(obj) = cpLess) then
  3928.           begin
  3929.             Result := false;
  3930.             if assigned(callback) then
  3931.               callback(sender, veInvalidRange, objpath);
  3932.           end;
  3933.           o := length.AsObject.GetO('minex');
  3934.           if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then
  3935.           begin
  3936.             Result := false;
  3937.             if assigned(callback) then
  3938.               callback(sender, veInvalidRange, objpath);
  3939.           end;
  3940.           o := length.AsObject.GetO('maxex');
  3941.           if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then
  3942.           begin
  3943.             Result := false;
  3944.             if assigned(callback) then
  3945.               callback(sender, veInvalidRange, objpath);
  3946.           end;
  3947.         end;
  3948.       stNull: ;
  3949.     else
  3950.       Result := false;
  3951.       if assigned(callback) then
  3952.         callback(sender, veRuleMalformated, '');
  3953.     end;
  3954.   end;
  3955.  
  3956.  
  3957.   function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean;
  3958.   var
  3959.     ite: TSuperAvlIterator;
  3960.     ent: TSuperAvlEntry;
  3961.     p2, o2, sequence: ISuperObject;
  3962.     s: SOString;
  3963.     i: integer;
  3964.     uniquelist, fieldlist: ISuperObject;
  3965.   begin
  3966.     Result := true;
  3967.     if (o = nil) then
  3968.     begin
  3969.       if getInheritedBool('required', p) then
  3970.       begin
  3971.         if assigned(callback) then
  3972.           callback(sender, veFieldIsRequired, objpath);
  3973.         result := false;
  3974.       end;
  3975.     end else
  3976.       case FindDataType(p) of
  3977.         dtStr:
  3978.           case ObjectGetType(o) of
  3979.             stString:
  3980.               begin
  3981.                 Result := Result and CheckLength(Length(o.AsString), p, objpath);
  3982.                 Result := Result and CheckRange(o, p, objpath);
  3983.               end;
  3984.           else
  3985.             if assigned(callback) then
  3986.               callback(sender, veInvalidDataType, objpath);
  3987.             result := false;
  3988.           end;
  3989.         dtBool:
  3990.           case ObjectGetType(o) of
  3991.             stBoolean:
  3992.               begin
  3993.                 Result := Result and CheckRange(o, p, objpath);
  3994.               end;
  3995.           else
  3996.             if assigned(callback) then
  3997.               callback(sender, veInvalidDataType, objpath);
  3998.             result := false;
  3999.           end;
  4000.         dtInt:
  4001.           case ObjectGetType(o) of
  4002.             stInt:
  4003.               begin
  4004.                 Result := Result and CheckRange(o, p, objpath);
  4005.               end;
  4006.           else
  4007.             if assigned(callback) then
  4008.               callback(sender, veInvalidDataType, objpath);
  4009.             result := false;
  4010.           end;
  4011.         dtFloat:
  4012.           case ObjectGetType(o) of
  4013.             stDouble, stCurrency:
  4014.               begin
  4015.                 Result := Result and CheckRange(o, p, objpath);
  4016.               end;
  4017.           else
  4018.             if assigned(callback) then
  4019.               callback(sender, veInvalidDataType, objpath);
  4020.             result := false;
  4021.           end;
  4022.         dtMap:
  4023.           case ObjectGetType(o) of
  4024.             stObject:
  4025.               begin
  4026.                 // all objects have and match a rule ?
  4027.                 ite := TSuperAvlIterator.Create(o.AsObject);
  4028.                 try
  4029.                   ite.First;
  4030.                   ent := ite.GetIter;
  4031.                   while ent <> nil do
  4032.                   begin
  4033.                     p2 :=  FindInheritedField(ent.Name, p);
  4034.                     if ObjectIsType(p2, stObject) then
  4035.                       result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else
  4036.                     begin
  4037.                       if assigned(callback) then
  4038.                         callback(sender, veUnexpectedField, objpath + '.' + ent.Name);
  4039.                       result := false; // field have no rule
  4040.                     end;
  4041.                     ite.Next;
  4042.                     ent := ite.GetIter;
  4043.                   end;
  4044.                 finally
  4045.                   ite.Free;
  4046.                 end;
  4047.  
  4048.                 // all expected field exists ?
  4049.                 Result :=  InheritedFieldExist(o, p, objpath) and Result;
  4050.               end;
  4051.             stNull: {nop};
  4052.           else
  4053.             result := false;
  4054.             if assigned(callback) then
  4055.               callback(sender, veRuleMalformated, objpath);
  4056.           end;
  4057.         dtSeq:
  4058.           case ObjectGetType(o) of
  4059.             stArray:
  4060.               begin
  4061.                 sequence := FindInheritedProperty('sequence', p);
  4062.                 if sequence <> nil then
  4063.                 case ObjectGetType(sequence) of
  4064.                   stObject:
  4065.                     begin
  4066.                       for i := 0 to o.AsArray.Length - 1 do
  4067.                         result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result;
  4068.                       if getInheritedBool('unique', sequence) then
  4069.                       begin
  4070.                         // type is unique ?
  4071.                         uniquelist := TSuperObject.Create(stObject);
  4072.                         try
  4073.                           for i := 0 to o.AsArray.Length - 1 do
  4074.                           begin
  4075.                             s := o.AsArray.GetO(i).AsString;
  4076.                             if (s <> '') then
  4077.                             begin
  4078.                               if uniquelist.AsObject.Search(s) = nil then
  4079.                                 uniquelist[s] := nil else
  4080.                                 begin
  4081.                                   Result := False;
  4082.                                   if Assigned(callback) then
  4083.                                     callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']');
  4084.                                 end;
  4085.                             end;
  4086.                           end;
  4087.                         finally
  4088.                           uniquelist := nil;
  4089.                         end;
  4090.                       end;
  4091.  
  4092.                       // field is unique ?
  4093.                       if (FindDataType(sequence) = dtMap) then
  4094.                       begin
  4095.                         fieldlist := TSuperObject.Create(stObject);
  4096.                         try
  4097.                           GetInheritedFieldList(fieldlist, sequence);
  4098.                           ite := TSuperAvlIterator.Create(fieldlist.AsObject);
  4099.                           try
  4100.                             ite.First;
  4101.                             ent := ite.GetIter;
  4102.                             while ent <> nil do
  4103.                             begin
  4104.                               if getInheritedBool('unique', ent.Value) then
  4105.                               begin
  4106.                                 uniquelist := TSuperObject.Create(stObject);
  4107.                                 try
  4108.                                   for i := 0 to o.AsArray.Length - 1 do
  4109.                                   begin
  4110.                                     o2 := o.AsArray.GetO(i);
  4111.                                     if o2 <> nil then
  4112.                                     begin
  4113.                                       s := o2.AsObject.GetO(ent.Name).AsString;
  4114.                                       if (s <> '') then
  4115.                                       if uniquelist.AsObject.Search(s) = nil then
  4116.                                         uniquelist[s] := nil else
  4117.                                         begin
  4118.                                           Result := False;
  4119.                                           if Assigned(callback) then
  4120.                                             callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name);
  4121.                                         end;
  4122.                                     end;
  4123.                                   end;
  4124.                                 finally
  4125.                                   uniquelist := nil;
  4126.                                 end;
  4127.                               end;
  4128.                               ite.Next;
  4129.                               ent := ite.GetIter;
  4130.                             end;
  4131.                           finally
  4132.                             ite.Free;
  4133.                           end;
  4134.                         finally
  4135.                           fieldlist := nil;
  4136.                         end;
  4137.                       end;
  4138.  
  4139.  
  4140.                     end;
  4141.                   stNull: {nop};
  4142.                 else
  4143.                   result := false;
  4144.                   if assigned(callback) then
  4145.                     callback(sender, veRuleMalformated, objpath);
  4146.                 end;
  4147.                 Result := Result and CheckLength(o.AsArray.Length, p, objpath);
  4148.  
  4149.               end;
  4150.           else
  4151.             result := false;
  4152.             if assigned(callback) then
  4153.               callback(sender, veRuleMalformated, objpath);
  4154.           end;
  4155.         dtNumber:
  4156.           case ObjectGetType(o) of
  4157.             stInt,
  4158.             stDouble, stCurrency:
  4159.               begin
  4160.                 Result := Result and CheckRange(o, p, objpath);
  4161.               end;
  4162.           else
  4163.             if assigned(callback) then
  4164.               callback(sender, veInvalidDataType, objpath);
  4165.             result := false;
  4166.           end;
  4167.         dtText:
  4168.           case ObjectGetType(o) of
  4169.             stInt,
  4170.             stDouble,
  4171.             stCurrency,
  4172.             stString:
  4173.               begin
  4174.                 result := result and CheckLength(Length(o.AsString), p, objpath);
  4175.                 Result := Result and CheckRange(o, p, objpath);
  4176.               end;
  4177.           else
  4178.             if assigned(callback) then
  4179.               callback(sender, veInvalidDataType, objpath);
  4180.             result := false;
  4181.           end;
  4182.         dtScalar:
  4183.           case ObjectGetType(o) of
  4184.             stBoolean,
  4185.             stDouble,
  4186.             stCurrency,
  4187.             stInt,
  4188.             stString:
  4189.               begin
  4190.                 result := result and CheckLength(Length(o.AsString), p, objpath);
  4191.                 Result := Result and CheckRange(o, p, objpath);
  4192.               end;
  4193.           else
  4194.             if assigned(callback) then
  4195.               callback(sender, veInvalidDataType, objpath);
  4196.             result := false;
  4197.           end;
  4198.         dtAny:;
  4199.       else
  4200.         if assigned(callback) then
  4201.           callback(sender, veRuleMalformated, objpath);
  4202.         result := false;
  4203.       end;
  4204.       Result := Result and CheckEnum(o, p, objpath)
  4205.  
  4206.   end;
  4207. var
  4208.   j: integer;
  4209.  
  4210. begin
  4211.   Result := False;
  4212.   datatypes := TSuperObject.Create(stObject);
  4213.   names := TSuperObject.Create;
  4214.   try
  4215.     datatypes.I['str'] := ord(dtStr);
  4216.     datatypes.I['int'] := ord(dtInt);
  4217.     datatypes.I['float'] := ord(dtFloat);
  4218.     datatypes.I['number'] := ord(dtNumber);
  4219.     datatypes.I['text'] := ord(dtText);
  4220.     datatypes.I['bool'] := ord(dtBool);
  4221.     datatypes.I['map'] := ord(dtMap);
  4222.     datatypes.I['seq'] := ord(dtSeq);
  4223.     datatypes.I['scalar'] := ord(dtScalar);
  4224.     datatypes.I['any'] := ord(dtAny);
  4225.  
  4226.     if ObjectIsType(defs, stArray) then
  4227.       for j := 0 to defs.AsArray.Length - 1 do
  4228.         if ObjectIsType(defs.AsArray[j], stObject) then
  4229.           GetNames(defs.AsArray[j]) else
  4230.           begin
  4231.             if assigned(callback) then
  4232.               callback(sender, veRuleMalformated, '');
  4233.             Exit;
  4234.           end;
  4235.  
  4236.  
  4237.     if ObjectIsType(rules, stObject) then
  4238.       GetNames(rules) else
  4239.       begin
  4240.         if assigned(callback) then
  4241.           callback(sender, veRuleMalformated, '');
  4242.         Exit;
  4243.       end;
  4244.  
  4245.     Result := process(self, rules);
  4246.  
  4247.   finally
  4248.     datatypes := nil;
  4249.     names := nil;
  4250.   end;
  4251. end;
  4252.  
  4253. function TSuperObject._AddRef: Integer; stdcall;
  4254. begin
  4255.   Result := InterlockedIncrement(FRefCount);
  4256. end;
  4257.  
  4258. function TSuperObject._Release: Integer; stdcall;
  4259. begin
  4260.   Result := InterlockedDecrement(FRefCount);
  4261.   if Result = 0 then
  4262.     Destroy;
  4263. end;
  4264.  
  4265. function TSuperObject.Compare(const str: SOString): TSuperCompareResult;
  4266. begin
  4267.   Result := Compare(TSuperObject.ParseString(PSOChar(str), False));
  4268. end;
  4269.  
  4270. function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult;
  4271.   function GetIntCompResult(const i: int64): TSuperCompareResult;
  4272.   begin
  4273.     if i < 0 then result := cpLess else
  4274.     if i = 0 then result := cpEqu else
  4275.       Result := cpGreat;
  4276.   end;
  4277.  
  4278.   function GetDblCompResult(const d: double): TSuperCompareResult;
  4279.   begin
  4280.     if d < 0 then result := cpLess else
  4281.     if d = 0 then result := cpEqu else
  4282.       Result := cpGreat;
  4283.   end;
  4284.  
  4285. begin
  4286.   case DataType of
  4287.     stBoolean:
  4288.       case ObjectGetType(obj) of
  4289.         stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean));
  4290.         stDouble:  Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble);
  4291.         stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency);
  4292.         stInt:     Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger);
  4293.         stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
  4294.       else
  4295.         Result := cpError;
  4296.       end;
  4297.     stDouble:
  4298.       case ObjectGetType(obj) of
  4299.         stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean));
  4300.         stDouble:  Result := GetDblCompResult(FO.c_double - obj.AsDouble);
  4301.         stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency);
  4302.         stInt:     Result := GetDblCompResult(FO.c_double - obj.AsInteger);
  4303.         stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
  4304.       else
  4305.         Result := cpError;
  4306.       end;
  4307.     stCurrency:
  4308.       case ObjectGetType(obj) of
  4309.         stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean));
  4310.         stDouble:  Result := GetDblCompResult(FO.c_currency - obj.AsDouble);
  4311.         stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency);
  4312.         stInt:     Result := GetDblCompResult(FO.c_currency - obj.AsInteger);
  4313.         stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
  4314.       else
  4315.         Result := cpError;
  4316.       end;
  4317.     stInt:
  4318.       case ObjectGetType(obj) of
  4319.         stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean));
  4320.         stDouble:  Result := GetDblCompResult(FO.c_int - obj.AsDouble);
  4321.         stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency);
  4322.         stInt:     Result := GetIntCompResult(FO.c_int - obj.AsInteger);
  4323.         stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
  4324.       else
  4325.         Result := cpError;
  4326.       end;
  4327.     stString:
  4328.       case ObjectGetType(obj) of
  4329.         stBoolean,
  4330.         stDouble,
  4331.         stCurrency,
  4332.         stInt,
  4333.         stString:  Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
  4334.       else
  4335.         Result := cpError;
  4336.       end;
  4337.   else
  4338.     Result := cpError;
  4339.   end;
  4340. end;
  4341.  
  4342. {$IFDEF SUPER_METHOD}
  4343. function TSuperObject.AsMethod: TSuperMethod;
  4344. begin
  4345.   if FDataType = stMethod then
  4346.     Result := FO.c_method else
  4347.     Result := nil;
  4348. end;
  4349. {$ENDIF}
  4350.  
  4351. {$IFDEF SUPER_METHOD}
  4352. constructor TSuperObject.Create(m: TSuperMethod);
  4353. begin
  4354.   Create(stMethod);
  4355.   FO.c_method := m;
  4356. end;
  4357. {$ENDIF}
  4358.  
  4359. {$IFDEF SUPER_METHOD}
  4360. function TSuperObject.GetM(const path: SOString): TSuperMethod;
  4361. var
  4362.   v: ISuperObject;
  4363. begin
  4364.   v := ParseString(PSOChar(path), False, True, Self);
  4365.   if (v <> nil) and (ObjectGetType(v) = stMethod) then
  4366.     Result := v.AsMethod else
  4367.     Result := nil;
  4368. end;
  4369. {$ENDIF}
  4370.  
  4371. {$IFDEF SUPER_METHOD}
  4372. procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod);
  4373. begin
  4374.   ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
  4375. end;
  4376. {$ENDIF}
  4377.  
  4378. {$IFDEF SUPER_METHOD}
  4379. function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject;
  4380. begin
  4381.   Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param);
  4382. end;
  4383. {$ENDIF}
  4384.  
  4385. {$IFDEF SUPER_METHOD}
  4386. function TSuperObject.call(const path, param: SOString): ISuperObject;
  4387. begin
  4388.   Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False));
  4389. end;
  4390. {$ENDIF}
  4391.  
  4392. function TSuperObject.GetProcessing: boolean;
  4393. begin
  4394.   Result := FProcessing;
  4395. end;
  4396.  
  4397. procedure TSuperObject.SetDataPtr(const Value: Pointer);
  4398. begin
  4399.   FDataPtr := Value;
  4400. end;
  4401.  
  4402. procedure TSuperObject.SetProcessing(value: boolean);
  4403. begin
  4404.   FProcessing := value;
  4405. end;
  4406.  
  4407. { TSuperArray }
  4408.  
  4409. function TSuperArray.Add(const Data: ISuperObject): Integer;
  4410. begin
  4411.   Result := FLength;
  4412.   PutO(Result, data);
  4413. end;
  4414.  
  4415. function TSuperArray.Delete(index: Integer): ISuperObject;
  4416. begin
  4417.   if (Index >= 0) and (Index < FLength) then
  4418.   begin
  4419.     Result := FArray^[index];
  4420.     FArray^[index] := nil;
  4421.     Dec(FLength);
  4422.     if Index < FLength then
  4423.     begin
  4424.       Move(FArray^[index + 1], FArray^[index],
  4425.         (FLength - index) * SizeOf(Pointer));
  4426.       Pointer(FArray^[FLength]) := nil;
  4427.     end;
  4428.   end;
  4429. end;
  4430.  
  4431. procedure TSuperArray.Insert(index: Integer; const value: ISuperObject);
  4432. begin
  4433.   if (Index >= 0) then
  4434.   if (index < FLength) then
  4435.   begin
  4436.     if FLength = FSize then
  4437.       Expand(index);
  4438.     if Index < FLength then
  4439.       Move(FArray^[index], FArray^[index + 1],
  4440.         (FLength - index) * SizeOf(Pointer));
  4441.     Pointer(FArray^[index]) := nil;
  4442.     FArray^[index] := value;
  4443.     Inc(FLength);
  4444.   end else
  4445.     PutO(index, value);
  4446. end;
  4447.  
  4448. procedure TSuperArray.Clear(all: boolean);
  4449. var
  4450.   j: Integer;
  4451. begin
  4452.   for j := 0 to FLength - 1 do
  4453.     if FArray^[j] <> nil then
  4454.     begin
  4455.       if all then
  4456.         FArray^[j].Clear(all);
  4457.       FArray^[j] := nil;
  4458.     end;
  4459.   FLength := 0;
  4460. end;
  4461.  
  4462. procedure TSuperArray.Pack(all: boolean);
  4463. var
  4464.   PackedCount, StartIndex, EndIndex, j: Integer;
  4465. begin
  4466.   if FLength > 0 then
  4467.   begin
  4468.     PackedCount := 0;
  4469.     StartIndex := 0;
  4470.     repeat
  4471.       while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do
  4472.         Inc(StartIndex);
  4473.       if StartIndex < FLength then
  4474.         begin
  4475.           EndIndex := StartIndex;
  4476.           while (EndIndex < FLength) and  (FArray^[EndIndex] <> nil) do
  4477.             Inc(EndIndex);
  4478.  
  4479.           Dec(EndIndex);
  4480.  
  4481.           if StartIndex > PackedCount then
  4482.             Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer));
  4483.  
  4484.           Inc(PackedCount, EndIndex - StartIndex + 1);
  4485.           StartIndex := EndIndex + 1;
  4486.         end;
  4487.     until StartIndex >= FLength;
  4488.     FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0);
  4489.     FLength := PackedCount;
  4490.     if all then
  4491.       for j := 0 to FLength - 1 do
  4492.         FArray^[j].Pack(all);
  4493.   end;
  4494. end;
  4495.  
  4496. constructor TSuperArray.Create;
  4497. begin
  4498.   inherited Create;
  4499.   FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE;
  4500.   FLength := 0;
  4501.   GetMem(FArray, sizeof(Pointer) * FSize);
  4502.   FillChar(FArray^, sizeof(Pointer) * FSize, 0);
  4503. end;
  4504.  
  4505. destructor TSuperArray.Destroy;
  4506. begin
  4507.   Clear;
  4508.   FreeMem(FArray);
  4509.   inherited;
  4510. end;
  4511.  
  4512. procedure TSuperArray.Expand(max: Integer);
  4513. var
  4514.   new_size: Integer;
  4515. begin
  4516.   if (max < FSize) then
  4517.     Exit;
  4518.   if max < (FSize shl 1) then
  4519.     new_size := (FSize shl 1) else
  4520.     new_size := max + 1;
  4521.   ReallocMem(FArray, new_size * sizeof(Pointer));
  4522.   FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0);
  4523.   FSize := new_size;
  4524. end;
  4525.  
  4526. function TSuperArray.GetO(const index: Integer): ISuperObject;
  4527. begin
  4528.   if(index >= FLength) then
  4529.     Result := nil else
  4530.     Result := FArray^[index];
  4531. end;
  4532.  
  4533. function TSuperArray.GetB(const index: integer): Boolean;
  4534. var
  4535.   obj: ISuperObject;
  4536. begin
  4537.   obj := GetO(index);
  4538.   if obj <> nil then
  4539.     Result := obj.AsBoolean else
  4540.     Result := false;
  4541. end;
  4542.  
  4543. function TSuperArray.GetD(const index: integer): Double;
  4544. var
  4545.   obj: ISuperObject;
  4546. begin
  4547.   obj := GetO(index);
  4548.   if obj <> nil then
  4549.     Result := obj.AsDouble else
  4550.     Result := 0.0;
  4551. end;
  4552.  
  4553. function TSuperArray.GetI(const index: integer): SuperInt;
  4554. var
  4555.   obj: ISuperObject;
  4556. begin
  4557.   obj := GetO(index);
  4558.   if obj <> nil then
  4559.     Result := obj.AsInteger else
  4560.     Result := 0;
  4561. end;
  4562.  
  4563. function TSuperArray.GetS(const index: integer): SOString;
  4564. var
  4565.   obj: ISuperObject;
  4566. begin
  4567.   obj := GetO(index);
  4568.   if obj <> nil then
  4569.     Result := obj.AsString else
  4570.     Result := '';
  4571. end;
  4572.  
  4573. procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject);
  4574. begin
  4575.   Expand(index);
  4576.   FArray^[index] := value;
  4577.   if(FLength <= index) then FLength := index + 1;
  4578. end;
  4579.  
  4580. function TSuperArray.GetN(const index: integer): ISuperObject;
  4581. begin
  4582.   Result := GetO(index);
  4583.   if Result = nil then
  4584.     Result := TSuperObject.Create(stNull);
  4585. end;
  4586.  
  4587. procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject);
  4588. begin
  4589.   if Value <> nil then
  4590.     PutO(index, Value) else
  4591.     PutO(index, TSuperObject.Create(stNull));
  4592. end;
  4593.  
  4594. procedure TSuperArray.PutB(const index: integer; Value: Boolean);
  4595. begin
  4596.   PutO(index, TSuperObject.Create(Value));
  4597. end;
  4598.  
  4599. procedure TSuperArray.PutD(const index: integer; Value: Double);
  4600. begin
  4601.   PutO(index, TSuperObject.Create(Value));
  4602. end;
  4603.  
  4604. function TSuperArray.GetC(const index: integer): Currency;
  4605. var
  4606.   obj: ISuperObject;
  4607. begin
  4608.   obj := GetO(index);
  4609.   if obj <> nil then
  4610.     Result := obj.AsCurrency else
  4611.     Result := 0.0;
  4612. end;
  4613.  
  4614. procedure TSuperArray.PutC(const index: integer; Value: Currency);
  4615. begin
  4616.   PutO(index, TSuperObject.CreateCurrency(Value));
  4617. end;
  4618.  
  4619. procedure TSuperArray.PutI(const index: integer; Value: SuperInt);
  4620. begin
  4621.   PutO(index, TSuperObject.Create(Value));
  4622. end;
  4623.  
  4624. procedure TSuperArray.PutS(const index: integer; const Value: SOString);
  4625. begin
  4626.   PutO(index, TSuperObject.Create(Value));
  4627. end;
  4628.  
  4629. {$IFDEF SUPER_METHOD}
  4630. function TSuperArray.GetM(const index: integer): TSuperMethod;
  4631. var
  4632.   v: ISuperObject;
  4633. begin
  4634.   v := GetO(index);
  4635.   if (ObjectGetType(v) = stMethod) then
  4636.     Result := v.AsMethod else
  4637.     Result := nil;
  4638. end;
  4639. {$ENDIF}
  4640.  
  4641. {$IFDEF SUPER_METHOD}
  4642. procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod);
  4643. begin
  4644.   PutO(index, TSuperObject.Create(Value));
  4645. end;
  4646. {$ENDIF}
  4647.  
  4648. { TSuperWriterString }
  4649.  
  4650. function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer;
  4651.   function max(a, b: Integer): integer; begin if a > b then  Result := a else Result := b end;
  4652. begin
  4653.   Result := size;
  4654.   if Size > 0 then
  4655.   begin
  4656.     if (FSize - FBPos <= size) then
  4657.     begin
  4658.       FSize := max(FSize * 2, FBPos + size + 8);
  4659.       ReallocMem(FBuf, FSize * SizeOf(SOChar));
  4660.     end;
  4661.     // fast move
  4662.     case size of
  4663.     1: FBuf[FBPos] := buf^;
  4664.     2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^;
  4665.     4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^;
  4666.     else
  4667.       move(buf^, FBuf[FBPos], size * SizeOf(SOChar));
  4668.     end;
  4669.     inc(FBPos, size);
  4670.     FBuf[FBPos] := #0;
  4671.   end;
  4672. end;
  4673.  
  4674. function TSuperWriterString.Append(buf: PSOChar): Integer;
  4675. begin
  4676.   Result := Append(buf, strlen(buf));
  4677. end;
  4678.  
  4679. constructor TSuperWriterString.Create;
  4680. begin
  4681.   inherited;
  4682.   FSize := 32;
  4683.   FBPos := 0;
  4684.   GetMem(FBuf, FSize * SizeOf(SOChar));
  4685. end;
  4686.  
  4687. destructor TSuperWriterString.Destroy;
  4688. begin
  4689.   inherited;
  4690.   if FBuf <> nil then
  4691.     FreeMem(FBuf)
  4692. end;
  4693.  
  4694. function TSuperWriterString.GetString: SOString;
  4695. begin
  4696.   SetString(Result, FBuf, FBPos);
  4697. end;
  4698.  
  4699. procedure TSuperWriterString.Reset;
  4700. begin
  4701.   FBuf[0] := #0;
  4702.   FBPos := 0;
  4703. end;
  4704.  
  4705. procedure TSuperWriterString.TrimRight;
  4706. begin
  4707.   while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do
  4708.   begin
  4709.     dec(FBPos);
  4710.     FBuf[FBPos] := #0;
  4711.   end;
  4712. end;
  4713.  
  4714. { TSuperWriterStream }
  4715.  
  4716. function TSuperWriterStream.Append(buf: PSOChar): Integer;
  4717. begin
  4718.   Result := Append(buf, StrLen(buf));
  4719. end;
  4720.  
  4721. constructor TSuperWriterStream.Create(AStream: TStream);
  4722. begin
  4723.   inherited Create;
  4724.   FStream := AStream;
  4725. end;
  4726.  
  4727. procedure TSuperWriterStream.Reset;
  4728. begin
  4729.   FStream.Size := 0;
  4730. end;
  4731.  
  4732. { TSuperWriterStream }
  4733.  
  4734. function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
  4735. var
  4736.   Buffer: array[0..1023] of AnsiChar;
  4737.   pBuffer: PAnsiChar;
  4738.   i: Integer;
  4739. begin
  4740.   if Size = 1 then
  4741.     Result := FStream.Write(buf^, Size) else
  4742.   begin
  4743.     if Size > SizeOf(Buffer) then
  4744.       GetMem(pBuffer, Size) else
  4745.       pBuffer := @Buffer;
  4746.     try
  4747.       for i :=  0 to Size - 1 do
  4748.         pBuffer[i] := AnsiChar(buf[i]);
  4749.       Result := FStream.Write(pBuffer^, Size);
  4750.     finally
  4751.       if pBuffer <> @Buffer then
  4752.         FreeMem(pBuffer);
  4753.     end;
  4754.   end;
  4755. end;
  4756.  
  4757. { TSuperUnicodeWriterStream }
  4758.  
  4759. function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
  4760. begin
  4761.   Result := FStream.Write(buf^, Size * 2);
  4762. end;
  4763.  
  4764. { TSuperWriterFake }
  4765.  
  4766. function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer;
  4767. begin
  4768.   inc(FSize, Size);
  4769.   Result := FSize;
  4770. end;
  4771.  
  4772. function TSuperWriterFake.Append(buf: PSOChar): Integer;
  4773. begin
  4774.   inc(FSize, Strlen(buf));
  4775.   Result := FSize;
  4776. end;
  4777.  
  4778. constructor TSuperWriterFake.Create;
  4779. begin
  4780.   inherited Create;
  4781.   FSize := 0;
  4782. end;
  4783.  
  4784. procedure TSuperWriterFake.Reset;
  4785. begin
  4786.   FSize := 0;
  4787. end;
  4788.  
  4789. { TSuperWriterSock }
  4790.  
  4791. function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer;
  4792. var
  4793.   Buffer: array[0..1023] of AnsiChar;
  4794.   pBuffer: PAnsiChar;
  4795.   i: Integer;
  4796. begin
  4797.   if Size = 1 then
  4798. {$IFDEF FPC}
  4799.     Result := fpsend(FSocket, buf, size, 0) else
  4800. {$ELSE}
  4801.     Result := send(FSocket, buf^, size, 0) else
  4802. {$ENDIF}
  4803.   begin
  4804.     if Size > SizeOf(Buffer) then
  4805.       GetMem(pBuffer, Size) else
  4806.       pBuffer := @Buffer;
  4807.     try
  4808.       for i :=  0 to Size - 1 do
  4809.         pBuffer[i] := AnsiChar(buf[i]);
  4810. {$IFDEF FPC}
  4811.       Result := fpsend(FSocket, pBuffer, size, 0);
  4812. {$ELSE}
  4813.       Result := send(FSocket, pBuffer^, size, 0);
  4814. {$ENDIF}
  4815.     finally
  4816.       if pBuffer <> @Buffer then
  4817.         FreeMem(pBuffer);
  4818.     end;
  4819.   end;
  4820.   inc(FSize, Result);
  4821. end;
  4822.  
  4823. function TSuperWriterSock.Append(buf: PSOChar): Integer;
  4824. begin
  4825.   Result := Append(buf, StrLen(buf));
  4826. end;
  4827.  
  4828. constructor TSuperWriterSock.Create(ASocket: Integer);
  4829. begin
  4830.   inherited Create;
  4831.   FSocket := ASocket;
  4832.   FSize := 0;
  4833. end;
  4834.  
  4835. procedure TSuperWriterSock.Reset;
  4836. begin
  4837.   FSize := 0;
  4838. end;
  4839.  
  4840. { TSuperTokenizer }
  4841.  
  4842. constructor TSuperTokenizer.Create;
  4843. begin
  4844.   pb := TSuperWriterString.Create;
  4845.   line := 1;
  4846.   col := 0;
  4847.   Reset;
  4848. end;
  4849.  
  4850. destructor TSuperTokenizer.Destroy;
  4851. begin
  4852.   Reset;
  4853.   pb.Free;
  4854.   inherited;
  4855. end;
  4856.  
  4857. procedure TSuperTokenizer.Reset;
  4858. var
  4859.   i: integer;
  4860. begin
  4861.   for i := depth downto 0 do
  4862.     ResetLevel(i);
  4863.   depth := 0;
  4864.   err := teSuccess;
  4865. end;
  4866.  
  4867. procedure TSuperTokenizer.ResetLevel(adepth: integer);
  4868. begin
  4869.   stack[adepth].state := tsEatws;
  4870.   stack[adepth].saved_state := tsStart;
  4871.   stack[adepth].current := nil;
  4872.   stack[adepth].field_name := '';
  4873.   stack[adepth].obj := nil;
  4874.   stack[adepth].parent := nil;
  4875.   stack[adepth].gparent := nil;
  4876. end;
  4877.  
  4878. { TSuperAvlTree }
  4879.  
  4880. constructor TSuperAvlTree.Create;
  4881. begin
  4882.   FRoot := nil;
  4883.   FCount := 0;
  4884. end;
  4885.  
  4886. destructor TSuperAvlTree.Destroy;
  4887. begin
  4888.   Clear;
  4889.   inherited;
  4890. end;
  4891.  
  4892. function TSuperAvlTree.IsEmpty: boolean;
  4893. begin
  4894.   result := FRoot = nil;
  4895. end;
  4896.  
  4897. function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry;
  4898. var
  4899.   deep, old: TSuperAvlEntry;
  4900.   bf: integer;
  4901. begin
  4902.   if (bal.FBf > 0) then
  4903.   begin
  4904.     deep := bal.FGt;
  4905.     if (deep.FBf < 0) then
  4906.     begin
  4907.       old := bal;
  4908.       bal := deep.FLt;
  4909.       old.FGt := bal.FLt;
  4910.       deep.FLt := bal.FGt;
  4911.       bal.FLt := old;
  4912.       bal.FGt := deep;
  4913.       bf := bal.FBf;
  4914.       if (bf <> 0) then
  4915.       begin
  4916.         if (bf > 0) then
  4917.         begin
  4918.           old.FBf := -1;
  4919.           deep.FBf := 0;
  4920.         end else
  4921.         begin
  4922.           deep.FBf := 1;
  4923.           old.FBf := 0;
  4924.         end;
  4925.         bal.FBf := 0;
  4926.       end else
  4927.       begin
  4928.         old.FBf := 0;
  4929.         deep.FBf := 0;
  4930.       end;
  4931.     end else
  4932.     begin
  4933.       bal.FGt := deep.FLt;
  4934.       deep.FLt := bal;
  4935.       if (deep.FBf = 0) then
  4936.       begin
  4937.         deep.FBf := -1;
  4938.         bal.FBf := 1;
  4939.       end else
  4940.       begin
  4941.         deep.FBf := 0;
  4942.         bal.FBf := 0;
  4943.       end;
  4944.       bal := deep;
  4945.     end;
  4946.   end else
  4947.   begin
  4948.     (* "Less than" subtree is deeper. *)
  4949.  
  4950.     deep := bal.FLt;
  4951.     if (deep.FBf > 0) then
  4952.     begin
  4953.       old := bal;
  4954.       bal := deep.FGt;
  4955.       old.FLt := bal.FGt;
  4956.       deep.FGt := bal.FLt;
  4957.       bal.FGt := old;
  4958.       bal.FLt := deep;
  4959.  
  4960.       bf := bal.FBf;
  4961.       if (bf <> 0) then
  4962.       begin
  4963.         if (bf < 0) then
  4964.         begin
  4965.           old.FBf := 1;
  4966.           deep.FBf := 0;
  4967.         end else
  4968.         begin
  4969.           deep.FBf := -1;
  4970.           old.FBf := 0;
  4971.         end;
  4972.         bal.FBf := 0;
  4973.       end else
  4974.       begin
  4975.         old.FBf := 0;
  4976.         deep.FBf := 0;
  4977.       end;
  4978.     end else
  4979.     begin
  4980.       bal.FLt := deep.FGt;
  4981.       deep.FGt := bal;
  4982.       if (deep.FBf = 0) then
  4983.       begin
  4984.         deep.FBf := 1;
  4985.         bal.FBf := -1;
  4986.       end else
  4987.       begin
  4988.         deep.FBf := 0;
  4989.         bal.FBf := 0;
  4990.       end;
  4991.       bal := deep;
  4992.     end;
  4993.   end;
  4994.   Result := bal;
  4995. end;
  4996.  
  4997. function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry;
  4998. var
  4999.   unbal, parentunbal, hh, parent: TSuperAvlEntry;
  5000.   depth, unbaldepth: longint;
  5001.   cmp: integer;
  5002.   unbalbf: integer;
  5003.   branch: TSuperAvlBitArray;
  5004.   p: Pointer;
  5005. begin
  5006.   inc(FCount);
  5007.   h.FLt := nil;
  5008.   h.FGt := nil;
  5009.   h.FBf := 0;
  5010.   branch := [];
  5011.  
  5012.   if (FRoot = nil) then
  5013.     FRoot := h
  5014.   else
  5015.   begin
  5016.     unbal := nil;
  5017.     parentunbal := nil;
  5018.     depth := 0;
  5019.     unbaldepth := 0;
  5020.     hh := FRoot;
  5021.     parent := nil;
  5022.     repeat
  5023.       if (hh.FBf <> 0) then
  5024.       begin
  5025.         unbal := hh;
  5026.         parentunbal := parent;
  5027.         unbaldepth := depth;
  5028.       end;
  5029.       if hh.FHash <> h.FHash then
  5030.       begin
  5031.         if hh.FHash < h.FHash then cmp := -1 else
  5032.         if hh.FHash > h.FHash then cmp := 1 else
  5033.           cmp := 0;
  5034.       end else
  5035.         cmp := CompareNodeNode(h, hh);
  5036.       if (cmp = 0) then
  5037.       begin
  5038.         Result := hh;
  5039.         //exchange data
  5040.         p := hh.Ptr;
  5041.         hh.FPtr := h.Ptr;
  5042.         h.FPtr := p;
  5043.         doDeleteEntry(h, false);
  5044.         dec(FCount);
  5045.         exit;
  5046.       end;
  5047.       parent := hh;
  5048.       if (cmp > 0) then
  5049.       begin
  5050.         hh := hh.FGt;
  5051.         include(branch, depth);
  5052.       end else
  5053.       begin
  5054.         hh := hh.FLt;
  5055.         exclude(branch, depth);
  5056.       end;
  5057.       inc(depth);
  5058.     until (hh = nil);
  5059.  
  5060.     if (cmp < 0) then
  5061.       parent.FLt := h else
  5062.       parent.FGt := h;
  5063.  
  5064.     depth := unbaldepth;
  5065.  
  5066.     if (unbal = nil) then
  5067.       hh := FRoot
  5068.     else
  5069.     begin
  5070.       if depth in branch then
  5071.         cmp := 1 else
  5072.         cmp := -1;
  5073.       inc(depth);
  5074.       unbalbf := unbal.FBf;
  5075.       if (cmp < 0) then
  5076.         dec(unbalbf) else
  5077.         inc(unbalbf);
  5078.       if cmp < 0 then
  5079.         hh := unbal.FLt else
  5080.         hh := unbal.FGt;
  5081.       if ((unbalbf <> -2) and (unbalbf <> 2)) then
  5082.       begin
  5083.         unbal.FBf := unbalbf;
  5084.         unbal := nil;
  5085.       end;
  5086.     end;
  5087.  
  5088.     if (hh <> nil) then
  5089.       while (h <> hh) do
  5090.       begin
  5091.         if depth in branch then
  5092.           cmp := 1 else
  5093.           cmp := -1;
  5094.         inc(depth);
  5095.         if (cmp < 0) then
  5096.         begin
  5097.           hh.FBf := -1;
  5098.           hh := hh.FLt;
  5099.         end else (* cmp > 0 *)
  5100.         begin
  5101.           hh.FBf := 1;
  5102.           hh := hh.FGt;
  5103.         end;
  5104.       end;
  5105.  
  5106.     if (unbal <> nil) then
  5107.     begin
  5108.       unbal := balance(unbal);
  5109.       if (parentunbal = nil) then
  5110.         FRoot := unbal
  5111.       else
  5112.       begin
  5113.         depth := unbaldepth - 1;
  5114.         if depth in branch then
  5115.           cmp := 1 else
  5116.           cmp := -1;
  5117.         if (cmp < 0) then
  5118.           parentunbal.FLt := unbal else
  5119.           parentunbal.FGt := unbal;
  5120.       end;
  5121.     end;
  5122.   end;
  5123.   result := h;
  5124. end;
  5125.  
  5126. function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry;
  5127. var
  5128.   cmp, target_cmp: integer;
  5129.   match_h, h: TSuperAvlEntry;
  5130.   ha: Cardinal;
  5131. begin
  5132.   ha := TSuperAvlEntry.Hash(k);
  5133.  
  5134.   match_h := nil;
  5135.   h := FRoot;
  5136.  
  5137.   if (stLess in st) then
  5138.     target_cmp := 1 else
  5139.     if (stGreater in st) then
  5140.       target_cmp := -1 else
  5141.       target_cmp := 0;
  5142.  
  5143.   while (h <> nil) do
  5144.   begin
  5145.     if h.FHash < ha then cmp := -1 else
  5146.     if h.FHash > ha then cmp := 1 else
  5147.       cmp := 0;
  5148.  
  5149.     if cmp = 0 then
  5150.       cmp := CompareKeyNode(PSOChar(k), h);
  5151.     if (cmp = 0) then
  5152.     begin
  5153.       if (stEqual in st) then
  5154.       begin
  5155.         match_h := h;
  5156.         break;
  5157.       end;
  5158.       cmp := -target_cmp;
  5159.     end
  5160.     else
  5161.     if (target_cmp <> 0) then
  5162.       if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
  5163.         match_h := h;
  5164.     if cmp < 0 then
  5165.       h := h.FLt else
  5166.       h := h.FGt;
  5167.   end;
  5168.   result := match_h;
  5169. end;
  5170.  
  5171. function TSuperAvlTree.Delete(const k: SOString): ISuperObject;
  5172. var
  5173.   depth, rm_depth: longint;
  5174.   branch: TSuperAvlBitArray;
  5175.   h, parent, child, path, rm, parent_rm: TSuperAvlEntry;
  5176.   cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer;
  5177.   ha: Cardinal;
  5178. begin
  5179.   ha := TSuperAvlEntry.Hash(k);
  5180.   cmp_shortened_sub_with_path := 0;
  5181.   branch := [];
  5182.  
  5183.   depth := 0;
  5184.   h := FRoot;
  5185.   parent := nil;
  5186.   while true do
  5187.   begin
  5188.     if (h = nil) then
  5189.       exit;
  5190.     if h.FHash < ha then cmp := -1 else
  5191.     if h.FHash > ha then cmp := 1 else
  5192.       cmp := 0;
  5193.  
  5194.     if cmp = 0 then
  5195.       cmp := CompareKeyNode(k, h);
  5196.     if (cmp = 0) then
  5197.       break;
  5198.     parent := h;
  5199.     if (cmp > 0) then
  5200.     begin
  5201.       h := h.FGt;
  5202.       include(branch, depth)
  5203.     end else
  5204.     begin
  5205.       h := h.FLt;
  5206.       exclude(branch, depth)
  5207.     end;
  5208.     inc(depth);
  5209.     cmp_shortened_sub_with_path := cmp;
  5210.   end;
  5211.   rm := h;
  5212.   parent_rm := parent;
  5213.   rm_depth := depth;
  5214.  
  5215.   if (h.FBf < 0) then
  5216.   begin
  5217.     child := h.FLt;
  5218.     exclude(branch, depth);
  5219.     cmp := -1;
  5220.   end else
  5221.   begin
  5222.     child := h.FGt;
  5223.     include(branch, depth);
  5224.     cmp := 1;
  5225.   end;
  5226.   inc(depth);
  5227.  
  5228.   if (child <> nil) then
  5229.   begin
  5230.     cmp := -cmp;
  5231.     repeat
  5232.       parent := h;
  5233.       h := child;
  5234.       if (cmp < 0) then
  5235.       begin
  5236.         child := h.FLt;
  5237.         exclude(branch, depth);
  5238.       end else
  5239.       begin
  5240.         child := h.FGt;
  5241.         include(branch, depth);
  5242.       end;
  5243.       inc(depth);
  5244.     until (child = nil);
  5245.  
  5246.     if (parent = rm) then
  5247.       cmp_shortened_sub_with_path := -cmp else
  5248.       cmp_shortened_sub_with_path := cmp;
  5249.  
  5250.     if cmp > 0 then
  5251.       child := h.FLt else
  5252.       child := h.FGt;
  5253.   end;
  5254.  
  5255.   if (parent = nil) then
  5256.     FRoot := child else
  5257.     if (cmp_shortened_sub_with_path < 0) then
  5258.       parent.FLt := child else
  5259.       parent.FGt := child;
  5260.  
  5261.   if parent = rm then
  5262.     path := h else
  5263.     path := parent;
  5264.  
  5265.   if (h <> rm) then
  5266.   begin
  5267.     h.FLt := rm.FLt;
  5268.     h.FGt := rm.FGt;
  5269.     h.FBf := rm.FBf;
  5270.     if (parent_rm = nil) then
  5271.       FRoot := h
  5272.     else
  5273.     begin
  5274.       depth := rm_depth - 1;
  5275.       if (depth in branch) then
  5276.         parent_rm.FGt := h else
  5277.         parent_rm.FLt := h;
  5278.     end;
  5279.   end;
  5280.  
  5281.   if (path <> nil) then
  5282.   begin
  5283.     h := FRoot;
  5284.     parent := nil;
  5285.     depth := 0;
  5286.     while (h <> path) do
  5287.     begin
  5288.       if (depth in branch) then
  5289.       begin
  5290.         child := h.FGt;
  5291.         h.FGt := parent;
  5292.       end else
  5293.       begin
  5294.         child := h.FLt;
  5295.         h.FLt := parent;
  5296.       end;
  5297.       inc(depth);
  5298.       parent := h;
  5299.       h := child;
  5300.     end;
  5301.  
  5302.     reduced_depth := 1;
  5303.     cmp := cmp_shortened_sub_with_path;
  5304.     while true do
  5305.     begin
  5306.       if (reduced_depth <> 0) then
  5307.       begin
  5308.         bf := h.FBf;
  5309.         if (cmp < 0) then
  5310.           inc(bf) else
  5311.           dec(bf);
  5312.         if ((bf = -2) or (bf = 2)) then
  5313.         begin
  5314.           h := balance(h);
  5315.           bf := h.FBf;
  5316.         end else
  5317.           h.FBf := bf;
  5318.         reduced_depth := integer(bf = 0);
  5319.       end;
  5320.       if (parent = nil) then
  5321.         break;
  5322.       child := h;
  5323.       h := parent;
  5324.       dec(depth);
  5325.       if depth in branch then
  5326.         cmp := 1 else
  5327.         cmp := -1;
  5328.       if (cmp < 0) then
  5329.       begin
  5330.         parent := h.FLt;
  5331.         h.FLt := child;
  5332.       end else
  5333.       begin
  5334.         parent := h.FGt;
  5335.         h.FGt := child;
  5336.       end;
  5337.     end;
  5338.     FRoot := h;
  5339.   end;
  5340.   if rm <> nil then
  5341.   begin
  5342.     Result := rm.GetValue;
  5343.     doDeleteEntry(rm, false);
  5344.     dec(FCount);
  5345.   end;
  5346. end;
  5347.  
  5348. procedure TSuperAvlTree.Pack(all: boolean);
  5349. var
  5350.   node1, node2: TSuperAvlEntry;
  5351.   list: TList;
  5352.   i: Integer;
  5353. begin
  5354.   node1 := FRoot;
  5355.   list := TList.Create;
  5356.   while node1 <> nil do
  5357.   begin
  5358.     if (node1.FLt = nil) then
  5359.     begin
  5360.       node2 := node1.FGt;
  5361.       if (node1.FPtr = nil) then
  5362.         list.Add(node1) else
  5363.         if all then
  5364.           node1.Value.Pack(all);
  5365.     end
  5366.     else
  5367.     begin
  5368.       node2 := node1.FLt;
  5369.       node1.FLt := node2.FGt;
  5370.       node2.FGt := node1;
  5371.     end;
  5372.     node1 := node2;
  5373.   end;
  5374.   for i := 0 to list.Count - 1 do
  5375.     Delete(TSuperAvlEntry(list[i]).FName);
  5376.   list.Free;
  5377. end;
  5378.  
  5379. procedure TSuperAvlTree.Clear(all: boolean);
  5380. var
  5381.   node1, node2: TSuperAvlEntry;
  5382. begin
  5383.   node1 := FRoot;
  5384.   while node1 <> nil do
  5385.   begin
  5386.     if (node1.FLt = nil) then
  5387.     begin
  5388.       node2 := node1.FGt;
  5389.       doDeleteEntry(node1, all);
  5390.     end
  5391.     else
  5392.     begin
  5393.       node2 := node1.FLt;
  5394.       node1.FLt := node2.FGt;
  5395.       node2.FGt := node1;
  5396.     end;
  5397.     node1 := node2;
  5398.   end;
  5399.   FRoot := nil;
  5400.   FCount := 0;
  5401. end;
  5402.  
  5403. function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer;
  5404. begin
  5405.   Result := StrComp(PSOChar(k), PSOChar(h.FName));
  5406. end;
  5407.  
  5408. function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer;
  5409. begin
  5410.   Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName));
  5411. end;
  5412.  
  5413. { TSuperAvlIterator }
  5414.  
  5415. (* Initialize depth to invalid value, to indicate iterator is
  5416. ** invalid.   (Depth is zero-base.)  It's not necessary to initialize
  5417. ** iterators prior to passing them to the "start" function.
  5418. *)
  5419.  
  5420. constructor TSuperAvlIterator.Create(tree: TSuperAvlTree);
  5421. begin
  5422.   FDepth := not 0;
  5423.   FTree := tree;
  5424. end;
  5425.  
  5426. procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes);
  5427. var
  5428.   h: TSuperAvlEntry;
  5429.   d: longint;
  5430.   cmp, target_cmp: integer;
  5431.   ha: Cardinal;
  5432. begin
  5433.   ha := TSuperAvlEntry.Hash(k);
  5434.   h := FTree.FRoot;
  5435.   d := 0;
  5436.   FDepth := not 0;
  5437.   if (h = nil) then
  5438.     exit;
  5439.  
  5440.   if (stLess in st) then
  5441.     target_cmp := 1 else
  5442.       if (stGreater in st) then
  5443.         target_cmp := -1 else
  5444.           target_cmp := 0;
  5445.  
  5446.   while true do
  5447.   begin
  5448.     if h.FHash < ha then cmp := -1 else
  5449.     if h.FHash > ha then cmp := 1 else
  5450.       cmp := 0;
  5451.  
  5452.     if cmp = 0 then
  5453.       cmp := FTree.CompareKeyNode(k, h);
  5454.     if (cmp = 0) then
  5455.     begin
  5456.       if (stEqual in st) then
  5457.       begin
  5458.         FDepth := d;
  5459.         break;
  5460.       end;
  5461.       cmp := -target_cmp;
  5462.     end
  5463.     else
  5464.     if (target_cmp <> 0) then
  5465.       if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
  5466.         FDepth := d;
  5467.     if cmp < 0 then
  5468.       h := h.FLt else
  5469.       h := h.FGt;
  5470.     if (h = nil) then
  5471.       break;
  5472.     if (cmp > 0) then
  5473.       include(FBranch, d) else
  5474.       exclude(FBranch, d);
  5475.     FPath[d] := h;
  5476.     inc(d);
  5477.   end;
  5478. end;
  5479.  
  5480. procedure TSuperAvlIterator.First;
  5481. var
  5482.   h: TSuperAvlEntry;
  5483. begin
  5484.   h := FTree.FRoot;
  5485.   FDepth := not 0;
  5486.   FBranch := [];
  5487.   while (h <> nil) do
  5488.   begin
  5489.     if (FDepth <> not 0) then
  5490.       FPath[FDepth] := h;
  5491.     inc(FDepth);
  5492.     h := h.FLt;
  5493.   end;
  5494. end;
  5495.  
  5496. procedure TSuperAvlIterator.Last;
  5497. var
  5498.   h: TSuperAvlEntry;
  5499. begin
  5500.   h := FTree.FRoot;
  5501.   FDepth := not 0;
  5502.   FBranch := [0..SUPER_AVL_MAX_DEPTH - 1];
  5503.   while (h <> nil) do
  5504.   begin
  5505.     if (FDepth <> not 0) then
  5506.       FPath[FDepth] := h;
  5507.     inc(FDepth);
  5508.     h := h.FGt;
  5509.   end;
  5510. end;
  5511.  
  5512. function TSuperAvlIterator.MoveNext: boolean;
  5513. begin
  5514.   if FDepth = not 0 then
  5515.     First else
  5516.     Next;
  5517.   Result := GetIter <> nil;
  5518. end;
  5519.  
  5520. function TSuperAvlIterator.GetIter: TSuperAvlEntry;
  5521. begin
  5522.   if (FDepth = not 0) then
  5523.   begin
  5524.     result := nil;
  5525.     exit;
  5526.   end;
  5527.   if FDepth = 0 then
  5528.     Result := FTree.FRoot else
  5529.     Result := FPath[FDepth - 1];
  5530. end;
  5531.  
  5532. procedure TSuperAvlIterator.Next;
  5533. var
  5534.   h: TSuperAvlEntry;
  5535. begin
  5536.   if (FDepth <> not 0) then
  5537.   begin
  5538.     if FDepth = 0 then
  5539.       h := FTree.FRoot.FGt else
  5540.       h := FPath[FDepth - 1].FGt;
  5541.  
  5542.     if (h = nil) then
  5543.       repeat
  5544.         if (FDepth = 0) then
  5545.         begin
  5546.           FDepth := not 0;
  5547.           break;
  5548.         end;
  5549.         dec(FDepth);
  5550.       until (not (FDepth in FBranch))
  5551.     else
  5552.     begin
  5553.       include(FBranch, FDepth);
  5554.       FPath[FDepth] := h;
  5555.       inc(FDepth);
  5556.       while true do
  5557.       begin
  5558.         h := h.FLt;
  5559.         if (h = nil) then
  5560.           break;
  5561.         exclude(FBranch, FDepth);
  5562.         FPath[FDepth] := h;
  5563.         inc(FDepth);
  5564.       end;
  5565.     end;
  5566.   end;
  5567. end;
  5568.  
  5569. procedure TSuperAvlIterator.Prior;
  5570. var
  5571.   h: TSuperAvlEntry;
  5572. begin
  5573.   if (FDepth <> not 0) then
  5574.   begin
  5575.     if FDepth = 0 then
  5576.       h := FTree.FRoot.FLt else
  5577.       h := FPath[FDepth - 1].FLt;
  5578.     if (h = nil) then
  5579.       repeat
  5580.         if (FDepth = 0) then
  5581.         begin
  5582.           FDepth := not 0;
  5583.           break;
  5584.         end;
  5585.         dec(FDepth);
  5586.       until (FDepth in FBranch)
  5587.     else
  5588.     begin
  5589.       exclude(FBranch, FDepth);
  5590.       FPath[FDepth] := h;
  5591.       inc(FDepth);
  5592.       while true do
  5593.       begin
  5594.         h := h.FGt;
  5595.         if (h = nil) then
  5596.           break;
  5597.         include(FBranch, FDepth);
  5598.         FPath[FDepth] := h;
  5599.         inc(FDepth);
  5600.       end;
  5601.     end;
  5602.   end;
  5603. end;
  5604.  
  5605. procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
  5606. begin
  5607.   Entry.Free;
  5608. end;
  5609.  
  5610. function TSuperAvlTree.GetEnumerator: TSuperAvlIterator;
  5611. begin
  5612.   Result := TSuperAvlIterator.Create(Self);
  5613. end;
  5614.  
  5615. { TSuperAvlEntry }
  5616.  
  5617. constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer);
  5618. begin
  5619.   FName := AName;
  5620.   FPtr := Obj;
  5621.   FHash := Hash(FName);
  5622. end;
  5623.  
  5624. function TSuperAvlEntry.GetValue: ISuperObject;
  5625. begin
  5626.   Result := ISuperObject(FPtr)
  5627. end;
  5628.  
  5629. class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;
  5630. var
  5631.   h: cardinal;
  5632.   i: Integer;
  5633. begin
  5634.   h := 0;
  5635. {$Q-}
  5636.   for i := 1 to Length(k) do
  5637.     h := h*129 + ord(k[i]) + $9e370001;
  5638. {$Q+}
  5639.   Result := h;
  5640. end;
  5641.  
  5642. procedure TSuperAvlEntry.SetValue(const val: ISuperObject);
  5643. begin
  5644.   ISuperObject(FPtr) := val;
  5645. end;
  5646.  
  5647. { TSuperTableString }
  5648.  
  5649. function TSuperTableString.GetValues: ISuperObject;
  5650. var
  5651.   ite: TSuperAvlIterator;
  5652.   obj: TSuperAvlEntry;
  5653. begin
  5654.   Result := TSuperObject.Create(stArray);
  5655.   ite := TSuperAvlIterator.Create(Self);
  5656.   try
  5657.     ite.First;
  5658.     obj := ite.GetIter;
  5659.     while obj <> nil do
  5660.     begin
  5661.       Result.AsArray.Add(obj.Value);
  5662.       ite.Next;
  5663.       obj := ite.GetIter;
  5664.     end;
  5665.   finally
  5666.     ite.Free;
  5667.   end;
  5668. end;
  5669.  
  5670. function TSuperTableString.GetNames: ISuperObject;
  5671. var
  5672.   ite: TSuperAvlIterator;
  5673.   obj: TSuperAvlEntry;
  5674. begin
  5675.   Result := TSuperObject.Create(stArray);
  5676.   ite := TSuperAvlIterator.Create(Self);
  5677.   try
  5678.     ite.First;
  5679.     obj := ite.GetIter;
  5680.     while obj <> nil do
  5681.     begin
  5682.       Result.AsArray.Add(TSuperObject.Create(obj.FName));
  5683.       ite.Next;
  5684.       obj := ite.GetIter;
  5685.     end;
  5686.   finally
  5687.     ite.Free;
  5688.   end;
  5689. end;
  5690.  
  5691. procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
  5692. begin
  5693.   if Entry.Ptr <> nil then
  5694.   begin
  5695.     if all then Entry.Value.Clear(true);
  5696.     Entry.Value := nil;
  5697.   end;
  5698.   inherited;
  5699. end;
  5700.  
  5701. function TSuperTableString.GetO(const k: SOString): ISuperObject;
  5702. var
  5703.   e: TSuperAvlEntry;
  5704. begin
  5705.   e := Search(k);
  5706.   if e <> nil then
  5707.     Result := e.Value else
  5708.     Result := nil
  5709. end;
  5710.  
  5711. procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject);
  5712. var
  5713.   entry: TSuperAvlEntry;
  5714. begin
  5715.   entry := Insert(TSuperAvlEntry.Create(k, Pointer(value)));
  5716.   if entry.FPtr <> nil then
  5717.     ISuperObject(entry.FPtr)._AddRef;
  5718. end;
  5719.  
  5720. procedure TSuperTableString.PutS(const k: SOString; const value: SOString);
  5721. begin
  5722.   PutO(k, TSuperObject.Create(Value));
  5723. end;
  5724.  
  5725. function TSuperTableString.GetS(const k: SOString): SOString;
  5726. var
  5727.   obj: ISuperObject;
  5728. begin
  5729.  obj := GetO(k);
  5730.  if obj <> nil then
  5731.    Result := obj.AsString else
  5732.    Result := '';
  5733. end;
  5734.  
  5735. procedure TSuperTableString.PutI(const k: SOString; value: SuperInt);
  5736. begin
  5737.   PutO(k, TSuperObject.Create(Value));
  5738. end;
  5739.  
  5740. function TSuperTableString.GetI(const k: SOString): SuperInt;
  5741. var
  5742.   obj: ISuperObject;
  5743. begin
  5744.  obj := GetO(k);
  5745.  if obj <> nil then
  5746.    Result := obj.AsInteger else
  5747.    Result := 0;
  5748. end;
  5749.  
  5750. procedure TSuperTableString.PutD(const k: SOString; value: Double);
  5751. begin
  5752.   PutO(k, TSuperObject.Create(Value));
  5753. end;
  5754.  
  5755. procedure TSuperTableString.PutC(const k: SOString; value: Currency);
  5756. begin
  5757.   PutO(k, TSuperObject.CreateCurrency(Value));
  5758. end;
  5759.  
  5760. function TSuperTableString.GetC(const k: SOString): Currency;
  5761. var
  5762.   obj: ISuperObject;
  5763. begin
  5764.  obj := GetO(k);
  5765.  if obj <> nil then
  5766.    Result := obj.AsCurrency else
  5767.    Result := 0.0;
  5768. end;
  5769.  
  5770. function TSuperTableString.GetD(const k: SOString): Double;
  5771. var
  5772.   obj: ISuperObject;
  5773. begin
  5774.  obj := GetO(k);
  5775.  if obj <> nil then
  5776.    Result := obj.AsDouble else
  5777.    Result := 0.0;
  5778. end;
  5779.  
  5780. procedure TSuperTableString.PutB(const k: SOString; value: Boolean);
  5781. begin
  5782.   PutO(k, TSuperObject.Create(Value));
  5783. end;
  5784.  
  5785. function TSuperTableString.GetB(const k: SOString): Boolean;
  5786. var
  5787.   obj: ISuperObject;
  5788. begin
  5789.  obj := GetO(k);
  5790.  if obj <> nil then
  5791.    Result := obj.AsBoolean else
  5792.    Result := False;
  5793. end;
  5794.  
  5795. {$IFDEF SUPER_METHOD}
  5796. procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod);
  5797. begin
  5798.   PutO(k, TSuperObject.Create(Value));
  5799. end;
  5800. {$ENDIF}
  5801.  
  5802. {$IFDEF SUPER_METHOD}
  5803. function TSuperTableString.GetM(const k: SOString): TSuperMethod;
  5804. var
  5805.   obj: ISuperObject;
  5806. begin
  5807.  obj := GetO(k);
  5808.  if obj <> nil then
  5809.    Result := obj.AsMethod else
  5810.    Result := nil;
  5811. end;
  5812. {$ENDIF}
  5813.  
  5814. procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject);
  5815. begin
  5816.   if value <> nil then
  5817.     PutO(k, TSuperObject.Create(stNull)) else
  5818.     PutO(k, value);
  5819. end;
  5820.  
  5821. function TSuperTableString.GetN(const k: SOString): ISuperObject;
  5822. var
  5823.   obj: ISuperObject;
  5824. begin
  5825.  obj := GetO(k);
  5826.  if obj <> nil then
  5827.    Result := obj else
  5828.    Result := TSuperObject.Create(stNull);
  5829. end;
  5830.  
  5831.  
  5832. {$IFDEF VER210}
  5833.  
  5834. { TSuperAttribute }
  5835.  
  5836. constructor TSuperAttribute.Create(const AName: string);
  5837. begin
  5838.   FName := AName;
  5839. end;
  5840.  
  5841. { TSuperRttiContext }
  5842.  
  5843. constructor TSuperRttiContext.Create;
  5844. begin
  5845.   Context := TRttiContext.Create;
  5846.   SerialFromJson := TDictionary<PTypeInfo, TSerialFromJson>.Create;
  5847.   SerialToJson := TDictionary<PTypeInfo, TSerialToJson>.Create;
  5848.  
  5849.   SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean);
  5850.   SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime);
  5851.   SerialFromJson.Add(TypeInfo(TGUID), serialfromguid);
  5852.   SerialToJson.Add(TypeInfo(Boolean), serialtoboolean);
  5853.   SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime);
  5854.   SerialToJson.Add(TypeInfo(TGUID), serialtoguid);
  5855. end;
  5856.  
  5857. destructor TSuperRttiContext.Destroy;
  5858. begin
  5859.   SerialFromJson.Free;
  5860.   SerialToJson.Free;
  5861.   Context.Free;
  5862. end;
  5863.  
  5864. class function TSuperRttiContext.GetFieldName(r: TRttiField): string;
  5865. var
  5866.   o: TCustomAttribute;
  5867. begin
  5868.   for o in r.GetAttributes do
  5869.     if o is SOName then
  5870.       Exit(SOName(o).Name);
  5871.   Result := r.Name;
  5872. end;
  5873.  
  5874. class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
  5875. var
  5876.   o: TCustomAttribute;
  5877. begin
  5878.   if not ObjectIsType(obj, stNull) then Exit(obj);
  5879.   for o in r.GetAttributes do
  5880.     if o is SODefault then
  5881.       Exit(SO(SODefault(o).Name));
  5882.   Result := obj;
  5883. end;
  5884.  
  5885. function TSuperRttiContext.AsType<T>(const obj: ISuperObject): T;
  5886. var
  5887.   ret: TValue;
  5888. begin
  5889.   if FromJson(TypeInfo(T), obj, ret) then
  5890.     Result := ret.AsType<T> else
  5891.     raise exception.Create('Marshalling error');
  5892. end;
  5893.  
  5894. function TSuperRttiContext.AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject;
  5895. var
  5896.   v: TValue;
  5897. begin
  5898.   TValue.MakeWithoutCopy(@obj, TypeInfo(T), v);
  5899.   if index <> nil then
  5900.     Result := ToJson(v, index) else
  5901.     Result := ToJson(v, so);
  5902. end;
  5903.  
  5904. function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject;
  5905.   var Value: TValue): Boolean;
  5906.  
  5907.   procedure FromChar;
  5908.   begin
  5909.     if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
  5910.       begin
  5911.         Value := string(AnsiString(obj.AsString)[1]);
  5912.         Result := True;
  5913.       end else
  5914.         Result := False;
  5915.   end;
  5916.  
  5917.   procedure FromWideChar;
  5918.   begin
  5919.     if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
  5920.     begin
  5921.       Value := obj.AsString[1];
  5922.       Result := True;
  5923.     end else
  5924.       Result := False;
  5925.   end;
  5926.  
  5927.   procedure FromInt64;
  5928.   var
  5929.     i: Int64;
  5930.   begin
  5931.     case ObjectGetType(obj) of
  5932.     stInt:
  5933.       begin
  5934.         TValue.Make(nil, TypeInfo, Value);
  5935.         TValueData(Value).FAsSInt64 := obj.AsInteger;
  5936.         Result := True;
  5937.       end;
  5938.     stString:
  5939.       begin
  5940.         if TryStrToInt64(obj.AsString, i) then
  5941.         begin
  5942.           TValue.Make(nil, TypeInfo, Value);
  5943.           TValueData(Value).FAsSInt64 := i;
  5944.           Result := True;
  5945.         end else
  5946.           Result := False;
  5947.       end;
  5948.     else
  5949.       Result := False;
  5950.     end;
  5951.   end;
  5952.  
  5953.   procedure FromInt(const obj: ISuperObject);
  5954.   var
  5955.     TypeData: PTypeData;
  5956.     i: Integer;
  5957.     o: ISuperObject;
  5958.   begin
  5959.     case ObjectGetType(obj) of
  5960.     stInt, stBoolean:
  5961.       begin
  5962.         i := obj.AsInteger;
  5963.         TypeData := GetTypeData(TypeInfo);
  5964.         Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue);
  5965.         if Result then
  5966.           TValue.Make(@i, TypeInfo, Value);
  5967.       end;
  5968.     stString:
  5969.       begin
  5970.         o := SO(obj.AsString);
  5971.         if not ObjectIsType(o, stString) then
  5972.           FromInt(o) else
  5973.           Result := False;
  5974.       end;
  5975.     else
  5976.       Result := False;
  5977.     end;
  5978.   end;
  5979.  
  5980.   procedure fromSet;
  5981.   begin
  5982.     if ObjectIsType(obj, stInt) then
  5983.     begin
  5984.       TValue.Make(nil, TypeInfo, Value);
  5985.       TValueData(Value).FAsSLong := obj.AsInteger;
  5986.       Result := True;
  5987.     end else
  5988.       Result := False;
  5989.   end;
  5990.  
  5991.   procedure FromFloat(const obj: ISuperObject);
  5992.   var
  5993.     o: ISuperObject;
  5994.   begin
  5995.     case ObjectGetType(obj) of
  5996.     stInt, stDouble, stCurrency:
  5997.       begin
  5998.         TValue.Make(nil, TypeInfo, Value);
  5999.         case GetTypeData(TypeInfo).FloatType of
  6000.           ftSingle: TValueData(Value).FAsSingle := obj.AsDouble;
  6001.           ftDouble: TValueData(Value).FAsDouble := obj.AsDouble;
  6002.           ftExtended: TValueData(Value).FAsExtended := obj.AsDouble;
  6003.           ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger;
  6004.           ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency;
  6005.         end;
  6006.         Result := True;
  6007.       end;
  6008.     stString:
  6009.       begin
  6010.         o := SO(obj.AsString);
  6011.         if not ObjectIsType(o, stString) then
  6012.           FromFloat(o) else
  6013.           Result := False;
  6014.       end
  6015.     else
  6016.        Result := False;
  6017.     end;
  6018.   end;
  6019.  
  6020.   procedure FromString;
  6021.   begin
  6022.     case ObjectGetType(obj) of
  6023.     stObject, stArray:
  6024.       Result := False;
  6025.     stnull:
  6026.       begin
  6027.         Value := '';
  6028.         Result := True;
  6029.       end;
  6030.     else
  6031.       Value := obj.AsString;
  6032.       Result := True;
  6033.     end;
  6034.   end;
  6035.  
  6036.   procedure FromClass;
  6037.   var
  6038.     f: TRttiField;
  6039.     v: TValue;
  6040.   begin
  6041.     case ObjectGetType(obj) of
  6042.       stObject:
  6043.         begin
  6044.           Result := True;
  6045.           if Value.Kind <> tkClass then
  6046.             Value := GetTypeData(TypeInfo).ClassType.Create;
  6047.           for f in Context.GetType(Value.AsObject.ClassType).GetFields do
  6048.             if f.FieldType <> nil then
  6049.             begin
  6050.               Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
  6051.               if Result then
  6052.                 f.SetValue(Value.AsObject, v) else
  6053.                 Exit;
  6054.             end;
  6055.         end;
  6056.       stNull:
  6057.         begin
  6058.           Value := nil;
  6059.           Result := True;
  6060.         end
  6061.     else
  6062.       // error
  6063.       Value := nil;
  6064.       Result := False;
  6065.     end;
  6066.   end;
  6067.  
  6068.   procedure FromRecord;
  6069.   var
  6070.     f: TRttiField;
  6071.     p: Pointer;
  6072.     v: TValue;
  6073.   begin
  6074.     Result := True;
  6075.     TValue.Make(nil, TypeInfo, Value);
  6076.     for f in Context.GetType(TypeInfo).GetFields do
  6077.     begin
  6078.       if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then
  6079.       begin
  6080.         p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData;
  6081.         Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
  6082.         if Result then
  6083.           f.SetValue(p, v) else
  6084.           Exit;
  6085.       end else
  6086.       begin
  6087.         Result := False;
  6088.         Exit;
  6089.       end;
  6090.     end;
  6091.   end;
  6092.  
  6093.   procedure FromDynArray;
  6094.   var
  6095.     i: Integer;
  6096.     p: Pointer;
  6097.     pb: PByte;
  6098.     val: TValue;
  6099.     typ: PTypeData;
  6100.     el: PTypeInfo;
  6101.   begin
  6102.     case ObjectGetType(obj) of
  6103.     stArray:
  6104.       begin
  6105.         i := obj.AsArray.Length;
  6106.         p := nil;
  6107.         DynArraySetLength(p, TypeInfo, 1, @i);
  6108.         pb := p;
  6109.         typ := GetTypeData(TypeInfo);
  6110.         if typ.elType <> nil then
  6111.           el := typ.elType^ else
  6112.           el := typ.elType2^;
  6113.  
  6114.         Result := True;
  6115.         for i := 0 to i - 1 do
  6116.         begin
  6117.           Result := FromJson(el, obj.AsArray[i], val);
  6118.           if not Result then
  6119.             Break;
  6120.           val.ExtractRawData(pb);
  6121.           val := TValue.Empty;
  6122.           Inc(pb, typ.elSize);
  6123.         end;
  6124.         if Result then
  6125.           TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
  6126.           DynArrayClear(p, TypeInfo);
  6127.       end;
  6128.     stNull:
  6129.       begin
  6130.         TValue.MakeWithoutCopy(nil, TypeInfo, Value);
  6131.         Result := True;
  6132.       end;
  6133.     else
  6134.       i := 1;
  6135.       p := nil;
  6136.       DynArraySetLength(p, TypeInfo, 1, @i);
  6137.       pb := p;
  6138.       typ := GetTypeData(TypeInfo);
  6139.       if typ.elType <> nil then
  6140.         el := typ.elType^ else
  6141.         el := typ.elType2^;
  6142.  
  6143.       Result := FromJson(el, obj, val);
  6144.       val.ExtractRawData(pb);
  6145.       val := TValue.Empty;
  6146.  
  6147.       if Result then
  6148.         TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
  6149.         DynArrayClear(p, TypeInfo);
  6150.     end;
  6151.   end;
  6152.  
  6153.   procedure FromArray;
  6154.   var
  6155.     ArrayData: PArrayTypeData;
  6156.     idx: Integer;
  6157.     function ProcessDim(dim: Byte; const o: ISuperobject): Boolean;
  6158.     var
  6159.       i: Integer;
  6160.       v: TValue;
  6161.       a: PTypeData;
  6162.     begin
  6163.       if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then
  6164.       begin
  6165.         a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData;
  6166.         if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then
  6167.         begin
  6168.           Result := False;
  6169.           Exit;
  6170.         end;
  6171.         Result := True;
  6172.         if dim = ArrayData.DimCount then
  6173.           for i := a.MinValue to a.MaxValue do
  6174.           begin
  6175.             Result := FromJson(ArrayData.ElType^, o.AsArray[i], v);
  6176.             if not Result then
  6177.               Exit;
  6178.             Value.SetArrayElement(idx, v);
  6179.             inc(idx);
  6180.           end
  6181.         else
  6182.           for i := a.MinValue to a.MaxValue do
  6183.           begin
  6184.             Result := ProcessDim(dim + 1, o.AsArray[i]);
  6185.             if not Result then
  6186.               Exit;
  6187.           end;
  6188.       end else
  6189.         Result := False;
  6190.     end;
  6191.   var
  6192.     i: Integer;
  6193.     v: TValue;
  6194.   begin
  6195.     TValue.Make(nil, TypeInfo, Value);
  6196.     ArrayData := @GetTypeData(TypeInfo).ArrayData;
  6197.     idx := 0;
  6198.     if ArrayData.DimCount = 1 then
  6199.     begin
  6200.       if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then
  6201.       begin
  6202.         Result := True;
  6203.         for i := 0 to ArrayData.ElCount - 1 do
  6204.         begin
  6205.           Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v);
  6206.           if not Result then
  6207.             Exit;
  6208.           Value.SetArrayElement(idx, v);
  6209.           v := TValue.Empty;
  6210.           inc(idx);
  6211.         end;
  6212.       end else
  6213.         Result := False;
  6214.     end else
  6215.       Result := ProcessDim(1, obj);
  6216.   end;
  6217.  
  6218.   procedure FromClassRef;
  6219.   var
  6220.     r: TRttiType;
  6221.   begin
  6222.     if ObjectIsType(obj, stString) then
  6223.     begin
  6224.       r := Context.FindType(obj.AsString);
  6225.       if r <> nil then
  6226.       begin
  6227.         Value := TRttiInstanceType(r).MetaclassType;
  6228.         Result := True;
  6229.       end else
  6230.         Result := False;
  6231.     end else
  6232.       Result := False;
  6233.   end;
  6234.  
  6235.   procedure FromUnknown;
  6236.   begin
  6237.     case ObjectGetType(obj) of
  6238.       stBoolean:
  6239.         begin
  6240.           Value := obj.AsBoolean;
  6241.           Result := True;
  6242.         end;
  6243.       stDouble:
  6244.         begin
  6245.           Value := obj.AsDouble;
  6246.           Result := True;
  6247.         end;
  6248.       stCurrency:
  6249.         begin
  6250.           Value := obj.AsCurrency;
  6251.           Result := True;
  6252.         end;
  6253.       stInt:
  6254.         begin
  6255.           Value := obj.AsInteger;
  6256.           Result := True;
  6257.         end;
  6258.       stString:
  6259.         begin
  6260.           Value := obj.AsString;
  6261.           Result := True;
  6262.         end
  6263.     else
  6264.       Value := nil;
  6265.       Result := False;
  6266.     end;
  6267.   end;
  6268.  
  6269.   procedure FromInterface;
  6270.   const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}';
  6271.   var
  6272.     o: ISuperObject;
  6273.   begin
  6274.     if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then
  6275.     begin
  6276.       if obj <> nil then
  6277.         TValue.Make(@obj, TypeInfo, Value) else
  6278.         begin
  6279.           o := TSuperObject.Create(stNull);
  6280.           TValue.Make(@o, TypeInfo, Value);
  6281.         end;
  6282.       Result := True;
  6283.     end else
  6284.       Result := False;
  6285.   end;
  6286. var
  6287.   Serial: TSerialFromJson;
  6288. begin
  6289.   if TypeInfo <> nil then
  6290.   begin
  6291.     if not SerialFromJson.TryGetValue(TypeInfo, Serial) then
  6292.       case TypeInfo.Kind of
  6293.         tkChar: FromChar;
  6294.         tkInt64: FromInt64;
  6295.         tkEnumeration, tkInteger: FromInt(obj);
  6296.         tkSet: fromSet;
  6297.         tkFloat: FromFloat(obj);
  6298.         tkString, tkLString, tkUString, tkWString: FromString;
  6299.         tkClass: FromClass;
  6300.         tkMethod: ;
  6301.         tkWChar: FromWideChar;
  6302.         tkRecord: FromRecord;
  6303.         tkPointer: ;
  6304.         tkInterface: FromInterface;
  6305.         tkArray: FromArray;
  6306.         tkDynArray: FromDynArray;
  6307.         tkClassRef: FromClassRef;
  6308.       else
  6309.         FromUnknown
  6310.       end else
  6311.       begin
  6312.         TValue.Make(nil, TypeInfo, Value);
  6313.         Result := Serial(Self, obj, Value);
  6314.       end;
  6315.   end else
  6316.     Result := False;
  6317. end;
  6318.  
  6319. function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject;
  6320.   procedure ToInt64;
  6321.   begin
  6322.     Result := TSuperObject.Create(SuperInt(Value.AsInt64));
  6323.   end;
  6324.  
  6325.   procedure ToChar;
  6326.   begin
  6327.     Result := TSuperObject.Create(string(Value.AsType<AnsiChar>));
  6328.   end;
  6329.  
  6330.   procedure ToInteger;
  6331.   begin
  6332.     Result := TSuperObject.Create(TValueData(Value).FAsSLong);
  6333.   end;
  6334.  
  6335.   procedure ToFloat;
  6336.   begin
  6337.     case Value.TypeData.FloatType of
  6338.       ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle);
  6339.       ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble);
  6340.       ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended);
  6341.       ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64);
  6342.       ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr);
  6343.     end;
  6344.   end;
  6345.  
  6346.   procedure ToString;
  6347.   begin
  6348.     Result := TSuperObject.Create(string(Value.AsType<string>));
  6349.   end;
  6350.  
  6351.   procedure ToClass;
  6352.   var
  6353.     o: ISuperObject;
  6354.     f: TRttiField;
  6355.     v: TValue;
  6356.   begin
  6357.     if TValueData(Value).FAsObject <> nil then
  6358.     begin
  6359.       o := index[IntToStr(Integer(Value.AsObject))];
  6360.       if o = nil then
  6361.       begin
  6362.         Result := TSuperObject.Create(stObject);
  6363.         index[IntToStr(Integer(Value.AsObject))] := Result;
  6364.         for f in Context.GetType(Value.AsObject.ClassType).GetFields do
  6365.           if f.FieldType <> nil then
  6366.           begin
  6367.             v := f.GetValue(Value.AsObject);
  6368.             Result.AsObject[GetFieldName(f)] := ToJson(v, index);
  6369.           end
  6370.       end else
  6371.         Result := o;
  6372.     end else
  6373.       Result := nil;
  6374.   end;
  6375.  
  6376.   procedure ToWChar;
  6377.   begin
  6378.     Result :=  TSuperObject.Create(string(Value.AsType<WideChar>));
  6379.   end;
  6380.  
  6381.   procedure ToVariant;
  6382.   begin
  6383.     Result := SO(Value.AsVariant);
  6384.   end;
  6385.  
  6386.   procedure ToRecord;
  6387.   var
  6388.     f: TRttiField;
  6389.     v: TValue;
  6390.   begin
  6391.     Result := TSuperObject.Create(stObject);
  6392.     for f in Context.GetType(Value.TypeInfo).GetFields do
  6393.     begin
  6394.       v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData);
  6395.       Result.AsObject[GetFieldName(f)] := ToJson(v, index);
  6396.     end;
  6397.   end;
  6398.  
  6399.   procedure ToArray;
  6400.   var
  6401.     idx: Integer;
  6402.     ArrayData: PArrayTypeData;
  6403.  
  6404.     procedure ProcessDim(dim: Byte; const o: ISuperObject);
  6405.     var
  6406.       dt: PTypeData;
  6407.       i: Integer;
  6408.       o2: ISuperObject;
  6409.       v: TValue;
  6410.     begin
  6411.       if ArrayData.Dims[dim-1] = nil then Exit;
  6412.       dt := GetTypeData(ArrayData.Dims[dim-1]^);
  6413.       if Dim = ArrayData.DimCount then
  6414.         for i := dt.MinValue to dt.MaxValue do
  6415.         begin
  6416.           v := Value.GetArrayElement(idx);
  6417.           o.AsArray.Add(toJSon(v, index));
  6418.           inc(idx);
  6419.         end
  6420.       else
  6421.         for i := dt.MinValue to dt.MaxValue do
  6422.         begin
  6423.           o2 := TSuperObject.Create(stArray);
  6424.           o.AsArray.Add(o2);
  6425.           ProcessDim(dim + 1, o2);
  6426.         end;
  6427.     end;
  6428.   var
  6429.     i: Integer;
  6430.     v: TValue;
  6431.   begin
  6432.     Result := TSuperObject.Create(stArray);
  6433.     ArrayData := @Value.TypeData.ArrayData;
  6434.     idx := 0;
  6435.     if ArrayData.DimCount = 1 then
  6436.       for i := 0 to ArrayData.ElCount - 1 do
  6437.       begin
  6438.         v := Value.GetArrayElement(i);
  6439.         Result.AsArray.Add(toJSon(v, index))
  6440.       end
  6441.     else
  6442.       ProcessDim(1, Result);
  6443.   end;
  6444.  
  6445.   procedure ToDynArray;
  6446.   var
  6447.     i: Integer;
  6448.     v: TValue;
  6449.   begin
  6450.     Result := TSuperObject.Create(stArray);
  6451.     for i := 0 to Value.GetArrayLength - 1 do
  6452.     begin
  6453.       v := Value.GetArrayElement(i);
  6454.       Result.AsArray.Add(toJSon(v, index));
  6455.     end;
  6456.   end;
  6457.  
  6458.   procedure ToClassRef;
  6459.   begin
  6460.     if TValueData(Value).FAsClass <> nil then
  6461.       Result :=  TSuperObject.Create(string(
  6462.         TValueData(Value).FAsClass.UnitName + '.' +
  6463.         TValueData(Value).FAsClass.ClassName)) else
  6464.       Result := nil;
  6465.   end;
  6466.  
  6467.   procedure ToInterface;
  6468.   begin
  6469.     if TValueData(Value).FHeapData <> nil then
  6470.       TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else
  6471.       Result := nil;
  6472.   end;
  6473.  
  6474. var
  6475.   Serial: TSerialToJson;
  6476. begin
  6477.   if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then
  6478.     case Value.Kind of
  6479.       tkInt64: ToInt64;
  6480.       tkChar: ToChar;
  6481.       tkSet, tkInteger, tkEnumeration: ToInteger;
  6482.       tkFloat: ToFloat;
  6483.       tkString, tkLString, tkUString, tkWString: ToString;
  6484.       tkClass: ToClass;
  6485.       tkWChar: ToWChar;
  6486.       tkVariant: ToVariant;
  6487.       tkRecord: ToRecord;
  6488.       tkArray: ToArray;
  6489.       tkDynArray: ToDynArray;
  6490.       tkClassRef: ToClassRef;
  6491.       tkInterface: ToInterface;
  6492.     else
  6493.       result := nil;
  6494.     end else
  6495.       Result := Serial(Self, value, index);
  6496. end;
  6497.  
  6498. { TSuperObjectHelper }
  6499.  
  6500. constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil);
  6501. var
  6502.   v: TValue;
  6503.   ctxowned: Boolean;
  6504. begin
  6505.   if ctx = nil then
  6506.   begin
  6507.     ctx := TSuperRttiContext.Create;
  6508.     ctxowned := True;
  6509.   end else
  6510.     ctxowned := False;
  6511.   try
  6512.     v := Self;
  6513.     if not ctx.FromJson(v.TypeInfo, obj, v) then
  6514.       raise Exception.Create('Invalid object');
  6515.   finally
  6516.     if ctxowned then
  6517.       ctx.Free;
  6518.   end;
  6519. end;
  6520.  
  6521. constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil);
  6522. begin
  6523.   FromJson(SO(str), ctx);
  6524. end;
  6525.  
  6526. function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
  6527. var
  6528.   v: TValue;
  6529.   ctxowned: boolean;
  6530. begin
  6531.   if ctx = nil then
  6532.   begin
  6533.     ctx := TSuperRttiContext.Create;
  6534.     ctxowned := True;
  6535.   end else
  6536.     ctxowned := False;
  6537.   try
  6538.     v := Self;
  6539.     Result := ctx.ToJson(v, SO);
  6540.   finally
  6541.     if ctxowned then
  6542.       ctx.Free;
  6543.   end;
  6544. end;
  6545.  
  6546. {$ENDIF}
  6547.  
  6548. {$IFDEF DEBUG}
  6549. initialization
  6550.  
  6551. finalization
  6552.   Assert(debugcount = 0, 'Memory leak');
  6553. {$ENDIF}
  6554. end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!