Delphi - Delphi7 调用阿里大于实现短信消息验证

        阿里大于是阿里通信旗下产品，融合了三大运营商的通信能力，提供包括短信、语音、流量直充、私密专线、店铺手机号等个性化服务。每条四分五，价钱还算公道，经老农测试，响应速度非常快，基本上是秒到。官方文档提供了JAVA、.NET、PHP、Python、C/C++、NodeJS 等语言的 Demo，唯独没有 Dephi，但这也不能怪马云，毕竟 Delphi 实在太小众了。

 　　最近用 Delphi 写个 App，注册用户需要用到手机短信验证，于是找到的阿里大于，使用 Delphi 7 写了个简单的 Demo 并测试通过，代码如下：

        注意，这里需要添加引用IdHTTP, IdHashMessageDigest, IdGlobal, IdHash 和 superobject.pas文件。

  1 unit uMain;
  2 
  3 interface
  4 
  5 uses
  6   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  7   Dialogs, StdCtrls, RzEdit, RzButton, IdBaseComponent, IdComponent, superobject,
  8   IdTCPConnection, IdTCPClient, IdHTTP, IdHashMessageDigest, IdGlobal, IdHash,
  9   RzLabel, Mask;
 10 
 11 type
 12   TFrmMain = class(TForm)
 13     btnExecute: TRzBitBtn;
 14     mmLogs: TRzMemo;
 15     lbAppKey: TRzLabel;
 16     lbAppSecret: TRzLabel;
 17     lbReceiveNumber: TRzLabel;
 18     lbFreeSignName: TRzLabel;
 19     lbTemplateCode: TRzLabel;
 20     lbTemplateContent: TRzLabel;
 21     edtAppKey: TRzEdit;
 22     edtAppSecret: TRzEdit;
 23     edtReceiveNumber: TRzEdit;
 24     edtFreeSignName: TRzEdit;
 25     edtTemplateCode: TRzEdit;
 26     edtTemplateContent: TRzEdit;
 27     btnExit: TRzBitBtn;
 28     procedure MsgDsp(v_Str: string);
 29     procedure btnExecuteClick(Sender: TObject);
 30     procedure btnExitClick(Sender: TObject);
 31     procedure FormShow(Sender: TObject);
 32   private
 33     { Private declarations }
 34   public
 35     { Public declarations }
 36   end;
 37 
 38 var
 39   FrmMain: TFrmMain;
 40 
 41 implementation
 42 {$R *.dfm}
 43 
 44 procedure TFrmMain.MsgDsp(v_Str: string);
 45 begin
 46   mmLogs.Lines.Add('[admin] - [' + v_Str + '] - [' + FormatDateTime('YYYY-MM-DD hh:mm:ss zzz', Now()) + ']');
 47 end;
 48 
 49 /// 全能地图（QQ：64445322）
 50 /// 

 51 /// 利用阿里大于接口发短信
 52 /// 阿里大于网址：http://www.alidayu.com
 53 /// 阿里大于短信接口文档：https://api.alidayu.com/doc2/apiDetail.htm?apiId=25450
 54 /// 
 55 /// TOP分配给应用的AppKey
 56 /// AppSecret
 57 /// 接收手机号码
 58 /// 短信签名，传入的短信签名必须是在阿里大于“管理中心-短信签名管理”中的可用签名
 59 /// 短信模板ID
 60 /// 短信模板变量，例如：{"code":"1234","product":"alidayu"}
 61 /// 下发结果消息
 62 /// 是否成功，True = 成功 ，false = 失败
 63 
 64 function SendSMS(const AppKey, AppSecret, ReceiveNumber, FreeSignName, TemplateCode, TemplateContent: string; var ResultMsg: string): Boolean;
 65 
 66   function GetStringMD5(const AInPut: string): string;
 67   var
 68     MD5: TIdHashMessageDigest5;
 69     Digest: T4x4LongWordRecord;
 70   begin
 71     MD5 := TIdHashMessageDigest5.Create;
 72     try
 73       Digest := MD5.HashValue(AInPut);
 74       Result := MD5.AsHex(Digest);
 75     finally
 76       MD5.Free;
 77     end;
 78   end;
 79 
 80 // 签名算法：http://open.taobao.com/doc2/detail.htm?articleId=101617&docType=1&treeId=1
 81   function MakeSign(const AParams: TStringList; const AppSecret: string): string;
 82   var
 83     I: Integer;
 84     Data: string;
 85   begin
 86     // 参数排序
 87     AParams.Sort;
 88     // 参数拼接
 89     Data := '';
 90     for I := 0 to AParams.Count - 1 do
 91       Data := Data + StringReplace(AParams[I], '=', '', [rfReplaceAll]);
 92     // MD5 算法
 93     Result := GetStringMD5(AppSecret + Data + AppSecret);
 94   end;
 95 
 96 var
 97   HTTP: TIdHTTP;
 98   Params: TStringList;
 99   Response: string;
100   JsonObject: ISuperObject;
101 begin
102   Result := False;
103   HTTP := TIdHTTP.Create(nil);
104   Params := TStringList.Create();
105   try
106     Params.Values['app_key'] := AppKey;
107     Params.Values['format'] := 'json';
108     Params.Values['method'] := 'alibaba.aliqin.fc.sms.num.send';
109     Params.Values['sign_method'] := 'md5';
110     Params.Values['timestamp'] := FormatDateTime('yyyy-MM-dd HH:mm:ss', Now);
111     Params.Values['v'] := '2.0';
112     Params.Values['sms_type'] := 'normal';
113     Params.Values['sms_free_sign_name'] := UTF8Encode(FreeSignName);
114     Params.Values['rec_num'] := ReceiveNumber;
115     Params.Values['sms_template_code'] := TemplateCode;
116     Params.Values['sms_param'] := UTF8Encode(TemplateContent);
117     Params.Values['sign'] := MakeSign(Params, AppSecret);
118     HTTP.HandleRedirects := True;
119     HTTP.Request.AcceptCharSet := 'utf-8';
120     HTTP.Request.ContentType := 'application/x-www-form-urlencoded';
121     try
122       Response := HTTP.Post('http://gw.api.taobao.com/router/rest', Params);
123     except
124       on E: Exception do
125       begin
126         ResultMsg := E.Message;
127         Exit;
128       end;
129     end;
130     JsonObject := SO(Response);
131     if JsonObject <> nil then
132     begin
133       ResultMsg := JsonObject.S['alibaba_aliqin_fc_sms_num_send_response.result.success'];
134       if ResultMsg <> '' then
135         Result := UpperCase(ResultMsg) = 'TRUE'
136       else
137       begin
138         ResultMsg := JsonObject.S['error_response.msg'];
139         Result := False;
140       end;
141     end;
142   finally
143     HTTP.Free;
144     Params.Free;
145   end;
146 end;
147 
148 procedure TFrmMain.btnExecuteClick(Sender: TObject);
149 var
150   vResult: string;
151 begin
152   try
153     if SendSMS(edtAppKey.Text, edtAppSecret.Text, edtReceiveNumber.Text, edtFreeSignName.Text, edtTemplateCode.Text, edtTemplateContent.Text, vResult) then
154     begin
155       MsgDsp('API调用成功[' + vResult + ']，请注意查收短消息！');
156     end
157     else
158     begin
159       MsgDsp('API调用失败，错误信息【' + vResult + '】');
160     end;
161   except
162     on E: Exception do
163     begin
164       MsgDsp('API调用异常，[' + vResult + ']，错误信息【' + E.Message + '】');
165     end;
166   end;
167 
168 end;
169 
170 procedure TFrmMain.btnExitClick(Sender: TObject);
171 begin
172   Self.Close;
173 end;
174 
175 procedure TFrmMain.FormShow(Sender: TObject);
176 begin
177   MsgDsp('系统启动成功！');
178 end;
179 
180 end.

View Code

 

Delphi 10.1 berlin 关键发送模块如下：

 1 /// 全能地图（QQ：64445322）
 2 /// 

 3 /// 利用阿里大于接口发短信
 4 /// 阿里大于网址：http://www.alidayu.com
 5 /// 阿里大于短信接口文档：https://api.alidayu.com/doc2/apiDetail.htm?apiId=25450
 6 /// 
 7 /// TOP分配给应用的AppKey
 8 /// AppSecret
 9 /// 接收手机号码
10 /// 短信签名，传入的短信签名必须是在阿里大于“管理中心-短信签名管理”中的可用签名
11 /// 短信模板ID
12 /// 短信模板变量，例如：{"code":"1234","product":"alidayu"}
13 /// 下发结果消息
14 /// 是否成功，True = 成功 ，false = 失败
15 function SendSMS(const AppKey, AppSecret, ReceiveNumber, FreeSignName, TemplateCode, TemplateContent: string; var ResultMsg: string): Boolean;
16 
17   // 签名算法：http://open.taobao.com/doc2/detail.htm?articleId=101617&docType=1&treeId=1
18   function MakeSign(const AParams: TStringList; const AppSecret: string): string;
19   var
20     I: Integer;
21     Data: string;
22   begin
23     // 参数排序
24     AParams.Sort;
25 
26     // 参数拼接
27     Data := '';
28     for I := 0 to AParams.Count - 1 do
29       Data := Data + AParams[I].Replace('=', '');
30 
31     // HMAC 算法
32     Result := THashMD5.GetHMAC(Data, AppSecret).ToUpper;
33   end;
34 
35 var
36   HTTP: TNetHTTPClient;
37   JsonObject: TJSONObject;
38   Params: TStringList;
39   Response: string;
40 begin
41   Result := False;
42 
43   HTTP := TNetHTTPClient.Create(nil);
44   Params := TStringList.Create();
45   try
46     Params.Values['app_key'] := AppKey;
47     Params.Values['format'] := 'json';
48     Params.Values['method'] := 'alibaba.aliqin.fc.sms.num.send';
49     Params.Values['sign_method'] := 'hmac';
50     Params.Values['timestamp'] := FormatDateTime('yyyy-MM-dd HH:mm:ss', Now);
51     Params.Values['v'] := '2.0';
52     Params.Values['sms_type'] := 'normal';
53     Params.Values['sms_free_sign_name'] := FreeSignName;
54     Params.Values['rec_num'] := ReceiveNumber;
55     Params.Values['sms_template_code'] := TemplateCode;
56     Params.Values['sms_param'] := TemplateContent;
57     Params.Values['sign'] := MakeSign(Params, AppSecret);
58 
59     HTTP.ContentType := 'application/x-www-form-urlencoded';
60     try
61       Response := HTTP.Post('https://eco.taobao.com/router/rest', Params).ContentAsString();
62     except
63       on E: Exception do
64       begin
65         ResultMsg := E.Message;
66         Exit;
67       end;
68     end;
69 
70     JsonObject := TJSONObject.ParseJSONValue(Response) as TJSONObject;
71     try
72       if JsonObject <> nil then
73       begin
74         if JsonObject.TryGetValue<string>('alibaba_aliqin_fc_sms_num_send_response.result.success', ResultMsg) then
75           Result := ResultMsg.ToUpper = 'TRUE'
76         else if JsonObject.TryGetValue<string>('error_response.msg', ResultMsg) then
77           Result := False;
78       end;
79 
80     finally
81       JsonObject.Free;
82     end;
83 
84   finally
85     HTTP.Free;
86     Params.Free;
87   end;
88 
89 end;

View Code

SuperObject.pas如下：

   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 
  12  * Web site   : http://www.progdigy.com
  13  *
  14  * This unit is inspired from the json c lib:
  15  *   Michael Clark 
  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]%')
  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(const IID: TGUID; out Obj): HResult; virtual; stdcall;
 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;
 756     SerialToJson: TDictionary;
 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(const obj: ISuperObject): T;
 762     function AsJson(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;
1592   ps: TArray;
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(const IID: TGUID; out Obj): HResult; stdcall;
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 {$UNDEF SaveQ} {$IFOPT Q+} {$Q-} {$DEFINE SaveQ} {$ENDIF}
5630 class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;
5631 var
5632   h: cardinal;
5633   i: Integer;
5634 begin
5635   h := 0;
5636 //{$Q-}
5637 
5638   for i := 1 to Length(k) do
5639     h := h*129 + ord(k[i]) + $9e370001;
5640 //{$Q+}
5641   Result := h;
5642 end;
5643 {$IFDEF SaveQ} {$Q+} {$UNDEF SaveQ} {$ENDIF}
5644 
5645 procedure TSuperAvlEntry.SetValue(const val: ISuperObject);
5646 begin
5647   ISuperObject(FPtr) := val;
5648 end;
5649 
5650 { TSuperTableString }
5651 
5652 function TSuperTableString.GetValues: ISuperObject;
5653 var
5654   ite: TSuperAvlIterator;
5655   obj: TSuperAvlEntry;
5656 begin
5657   Result := TSuperObject.Create(stArray);
5658   ite := TSuperAvlIterator.Create(Self);
5659   try
5660     ite.First;
5661     obj := ite.GetIter;
5662     while obj <> nil do
5663     begin
5664       Result.AsArray.Add(obj.Value);
5665       ite.Next;
5666       obj := ite.GetIter;
5667     end;
5668   finally
5669     ite.Free;
5670   end;
5671 end;
5672 
5673 function TSuperTableString.GetNames: ISuperObject;
5674 var
5675   ite: TSuperAvlIterator;
5676   obj: TSuperAvlEntry;
5677 begin
5678   Result := TSuperObject.Create(stArray);
5679   ite := TSuperAvlIterator.Create(Self);
5680   try
5681     ite.First;
5682     obj := ite.GetIter;
5683     while obj <> nil do
5684     begin
5685       Result.AsArray.Add(TSuperObject.Create(obj.FName));
5686       ite.Next;
5687       obj := ite.GetIter;
5688     end;
5689   finally
5690     ite.Free;
5691   end;
5692 end;
5693 
5694 procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
5695 begin
5696   if Entry.Ptr <> nil then
5697   begin
5698     if all then Entry.Value.Clear(true);
5699     Entry.Value := nil;
5700   end;
5701   inherited;
5702 end;
5703 
5704 function TSuperTableString.GetO(const k: SOString): ISuperObject;
5705 var
5706   e: TSuperAvlEntry;
5707 begin
5708   e := Search(k);
5709   if e <> nil then
5710     Result := e.Value else
5711     Result := nil
5712 end;
5713 
5714 procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject);
5715 var
5716   entry: TSuperAvlEntry;
5717 begin
5718   entry := Insert(TSuperAvlEntry.Create(k, Pointer(value)));
5719   if entry.FPtr <> nil then
5720     ISuperObject(entry.FPtr)._AddRef;
5721 end;
5722 
5723 procedure TSuperTableString.PutS(const k: SOString; const value: SOString);
5724 begin
5725   PutO(k, TSuperObject.Create(Value));
5726 end;
5727 
5728 function TSuperTableString.GetS(const k: SOString): SOString;
5729 var
5730   obj: ISuperObject;
5731 begin
5732  obj := GetO(k);
5733  if obj <> nil then
5734    Result := obj.AsString else
5735    Result := '';
5736 end;
5737 
5738 procedure TSuperTableString.PutI(const k: SOString; value: SuperInt);
5739 begin
5740   PutO(k, TSuperObject.Create(Value));
5741 end;
5742 
5743 function TSuperTableString.GetI(const k: SOString): SuperInt;
5744 var
5745   obj: ISuperObject;
5746 begin
5747  obj := GetO(k);
5748  if obj <> nil then
5749    Result := obj.AsInteger else
5750    Result := 0;
5751 end;
5752 
5753 procedure TSuperTableString.PutD(const k: SOString; value: Double);
5754 begin
5755   PutO(k, TSuperObject.Create(Value));
5756 end;
5757 
5758 procedure TSuperTableString.PutC(const k: SOString; value: Currency);
5759 begin
5760   PutO(k, TSuperObject.CreateCurrency(Value));
5761 end;
5762 
5763 function TSuperTableString.GetC(const k: SOString): Currency;
5764 var
5765   obj: ISuperObject;
5766 begin
5767  obj := GetO(k);
5768  if obj <> nil then
5769    Result := obj.AsCurrency else
5770    Result := 0.0;
5771 end;
5772 
5773 function TSuperTableString.GetD(const k: SOString): Double;
5774 var
5775   obj: ISuperObject;
5776 begin
5777  obj := GetO(k);
5778  if obj <> nil then
5779    Result := obj.AsDouble else
5780    Result := 0.0;
5781 end;
5782 
5783 procedure TSuperTableString.PutB(const k: SOString; value: Boolean);
5784 begin
5785   PutO(k, TSuperObject.Create(Value));
5786 end;
5787 
5788 function TSuperTableString.GetB(const k: SOString): Boolean;
5789 var
5790   obj: ISuperObject;
5791 begin
5792  obj := GetO(k);
5793  if obj <> nil then
5794    Result := obj.AsBoolean else
5795    Result := False;
5796 end;
5797 
5798 {$IFDEF SUPER_METHOD}
5799 procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod);
5800 begin
5801   PutO(k, TSuperObject.Create(Value));
5802 end;
5803 {$ENDIF}
5804 
5805 {$IFDEF SUPER_METHOD}
5806 function TSuperTableString.GetM(const k: SOString): TSuperMethod;
5807 var
5808   obj: ISuperObject;
5809 begin
5810  obj := GetO(k);
5811  if obj <> nil then
5812    Result := obj.AsMethod else
5813    Result := nil;
5814 end;
5815 {$ENDIF}
5816 
5817 procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject);
5818 begin
5819   if value <> nil then
5820     PutO(k, TSuperObject.Create(stNull)) else
5821     PutO(k, value);
5822 end;
5823 
5824 function TSuperTableString.GetN(const k: SOString): ISuperObject;
5825 var
5826   obj: ISuperObject;
5827 begin
5828  obj := GetO(k);
5829  if obj <> nil then
5830    Result := obj else
5831    Result := TSuperObject.Create(stNull);
5832 end;
5833 
5834 
5835 {$IFDEF VER210}
5836 
5837 { TSuperAttribute }
5838 
5839 constructor TSuperAttribute.Create(const AName: string);
5840 begin
5841   FName := AName;
5842 end;
5843 
5844 { TSuperRttiContext }
5845 
5846 constructor TSuperRttiContext.Create;
5847 begin
5848   Context := TRttiContext.Create;
5849   SerialFromJson := TDictionary.Create;
5850   SerialToJson := TDictionary.Create;
5851 
5852   SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean);
5853   SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime);
5854   SerialFromJson.Add(TypeInfo(TGUID), serialfromguid);
5855   SerialToJson.Add(TypeInfo(Boolean), serialtoboolean);
5856   SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime);
5857   SerialToJson.Add(TypeInfo(TGUID), serialtoguid);
5858 end;
5859 
5860 destructor TSuperRttiContext.Destroy;
5861 begin
5862   SerialFromJson.Free;
5863   SerialToJson.Free;
5864   Context.Free;
5865 end;
5866 
5867 class function TSuperRttiContext.GetFieldName(r: TRttiField): string;
5868 var
5869   o: TCustomAttribute;
5870 begin
5871   for o in r.GetAttributes do
5872     if o is SOName then
5873       Exit(SOName(o).Name);
5874   Result := r.Name;
5875 end;
5876 
5877 class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
5878 var
5879   o: TCustomAttribute;
5880 begin
5881   if not ObjectIsType(obj, stNull) then Exit(obj);
5882   for o in r.GetAttributes do
5883     if o is SODefault then
5884       Exit(SO(SODefault(o).Name));
5885   Result := obj;
5886 end;
5887 
5888 function TSuperRttiContext.AsType(const obj: ISuperObject): T;
5889 var
5890   ret: TValue;
5891 begin
5892   if FromJson(TypeInfo(T), obj, ret) then
5893     Result := ret.AsType else
5894     raise exception.Create('Marshalling error');
5895 end;
5896 
5897 function TSuperRttiContext.AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject;
5898 var
5899   v: TValue;
5900 begin
5901   TValue.MakeWithoutCopy(@obj, TypeInfo(T), v);
5902   if index <> nil then
5903     Result := ToJson(v, index) else
5904     Result := ToJson(v, so);
5905 end;
5906 
5907 function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject;
5908   var Value: TValue): Boolean;
5909 
5910   procedure FromChar;
5911   begin
5912     if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
5913       begin
5914         Value := string(AnsiString(obj.AsString)[1]);
5915         Result := True;
5916       end else
5917         Result := False;
5918   end;
5919 
5920   procedure FromWideChar;
5921   begin
5922     if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
5923     begin
5924       Value := obj.AsString[1];
5925       Result := True;
5926     end else
5927       Result := False;
5928   end;
5929 
5930   procedure FromInt64;
5931   var
5932     i: Int64;
5933   begin
5934     case ObjectGetType(obj) of
5935     stInt:
5936       begin
5937         TValue.Make(nil, TypeInfo, Value);
5938         TValueData(Value).FAsSInt64 := obj.AsInteger;
5939         Result := True;
5940       end;
5941     stString:
5942       begin
5943         if TryStrToInt64(obj.AsString, i) then
5944         begin
5945           TValue.Make(nil, TypeInfo, Value);
5946           TValueData(Value).FAsSInt64 := i;
5947           Result := True;
5948         end else
5949           Result := False;
5950       end;
5951     else
5952       Result := False;
5953     end;
5954   end;
5955 
5956   procedure FromInt(const obj: ISuperObject);
5957   var
5958     TypeData: PTypeData;
5959     i: Integer;
5960     o: ISuperObject;
5961   begin
5962     case ObjectGetType(obj) of
5963     stInt, stBoolean:
5964       begin
5965         i := obj.AsInteger;
5966         TypeData := GetTypeData(TypeInfo);
5967         Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue);
5968         if Result then
5969           TValue.Make(@i, TypeInfo, Value);
5970       end;
5971     stString:
5972       begin
5973         o := SO(obj.AsString);
5974         if not ObjectIsType(o, stString) then
5975           FromInt(o) else
5976           Result := False;
5977       end;
5978     else
5979       Result := False;
5980     end;
5981   end;
5982 
5983   procedure fromSet;
5984   begin
5985     if ObjectIsType(obj, stInt) then
5986     begin
5987       TValue.Make(nil, TypeInfo, Value);
5988       TValueData(Value).FAsSLong := obj.AsInteger;
5989       Result := True;
5990     end else
5991       Result := False;
5992   end;
5993 
5994   procedure FromFloat(const obj: ISuperObject);
5995   var
5996     o: ISuperObject;
5997   begin
5998     case ObjectGetType(obj) of
5999     stInt, stDouble, stCurrency:
6000       begin
6001         TValue.Make(nil, TypeInfo, Value);
6002         case GetTypeData(TypeInfo).FloatType of
6003           ftSingle: TValueData(Value).FAsSingle := obj.AsDouble;
6004           ftDouble: TValueData(Value).FAsDouble := obj.AsDouble;
6005           ftExtended: TValueData(Value).FAsExtended := obj.AsDouble;
6006           ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger;
6007           ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency;
6008         end;
6009         Result := True;
6010       end;
6011     stString:
6012       begin
6013         o := SO(obj.AsString);
6014         if not ObjectIsType(o, stString) then
6015           FromFloat(o) else
6016           Result := False;
6017       end
6018     else
6019        Result := False;
6020     end;
6021   end;
6022 
6023   procedure FromString;
6024   begin
6025     case ObjectGetType(obj) of
6026     stObject, stArray:
6027       Result := False;
6028     stnull:
6029       begin
6030         Value := '';
6031         Result := True;
6032       end;
6033     else
6034       Value := obj.AsString;
6035       Result := True;
6036     end;
6037   end;
6038 
6039   procedure FromClass;
6040   var
6041     f: TRttiField;
6042     v: TValue;
6043   begin
6044     case ObjectGetType(obj) of
6045       stObject:
6046         begin
6047           Result := True;
6048           if Value.Kind <> tkClass then
6049             Value := GetTypeData(TypeInfo).ClassType.Create;
6050           for f in Context.GetType(Value.AsObject.ClassType).GetFields do
6051             if f.FieldType <> nil then
6052             begin
6053               Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
6054               if Result then
6055                 f.SetValue(Value.AsObject, v) else
6056                 Exit;
6057             end;
6058         end;
6059       stNull:
6060         begin
6061           Value := nil;
6062           Result := True;
6063         end
6064     else
6065       // error
6066       Value := nil;
6067       Result := False;
6068     end;
6069   end;
6070 
6071   procedure FromRecord;
6072   var
6073     f: TRttiField;
6074     p: Pointer;
6075     v: TValue;
6076   begin
6077     Result := True;
6078     TValue.Make(nil, TypeInfo, Value);
6079     for f in Context.GetType(TypeInfo).GetFields do
6080     begin
6081       if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then
6082       begin
6083         p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData;
6084         Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
6085         if Result then
6086           f.SetValue(p, v) else
6087           Exit;
6088       end else
6089       begin
6090         Result := False;
6091         Exit;
6092       end;
6093     end;
6094   end;
6095 
6096   procedure FromDynArray;
6097   var
6098     i: Integer;
6099     p: Pointer;
6100     pb: PByte;
6101     val: TValue;
6102     typ: PTypeData;
6103     el: PTypeInfo;
6104   begin
6105     case ObjectGetType(obj) of
6106     stArray:
6107       begin
6108         i := obj.AsArray.Length;
6109         p := nil;
6110         DynArraySetLength(p, TypeInfo, 1, @i);
6111         pb := p;
6112         typ := GetTypeData(TypeInfo);
6113         if typ.elType <> nil then
6114           el := typ.elType^ else
6115           el := typ.elType2^;
6116 
6117         Result := True;
6118         for i := 0 to i - 1 do
6119         begin
6120           Result := FromJson(el, obj.AsArray[i], val);
6121           if not Result then
6122             Break;
6123           val.ExtractRawData(pb);
6124           val := TValue.Empty;
6125           Inc(pb, typ.elSize);
6126         end;
6127         if Result then
6128           TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
6129           DynArrayClear(p, TypeInfo);
6130       end;
6131     stNull:
6132       begin
6133         TValue.MakeWithoutCopy(nil, TypeInfo, Value);
6134         Result := True;
6135       end;
6136     else
6137       i := 1;
6138       p := nil;
6139       DynArraySetLength(p, TypeInfo, 1, @i);
6140       pb := p;
6141       typ := GetTypeData(TypeInfo);
6142       if typ.elType <> nil then
6143         el := typ.elType^ else
6144         el := typ.elType2^;
6145 
6146       Result := FromJson(el, obj, val);
6147       val.ExtractRawData(pb);
6148       val := TValue.Empty;
6149 
6150       if Result then
6151         TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
6152         DynArrayClear(p, TypeInfo);
6153     end;
6154   end;
6155 
6156   procedure FromArray;
6157   var
6158     ArrayData: PArrayTypeData;
6159     idx: Integer;
6160     function ProcessDim(dim: Byte; const o: ISuperobject): Boolean;
6161     var
6162       i: Integer;
6163       v: TValue;
6164       a: PTypeData;
6165     begin
6166       if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then
6167       begin
6168         a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData;
6169         if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then
6170         begin
6171           Result := False;
6172           Exit;
6173         end;
6174         Result := True;
6175         if dim = ArrayData.DimCount then
6176           for i := a.MinValue to a.MaxValue do
6177           begin
6178             Result := FromJson(ArrayData.ElType^, o.AsArray[i], v);
6179             if not Result then
6180               Exit;
6181             Value.SetArrayElement(idx, v);
6182             inc(idx);
6183           end
6184         else
6185           for i := a.MinValue to a.MaxValue do
6186           begin
6187             Result := ProcessDim(dim + 1, o.AsArray[i]);
6188             if not Result then
6189               Exit;
6190           end;
6191       end else
6192         Result := False;
6193     end;
6194   var
6195     i: Integer;
6196     v: TValue;
6197   begin
6198     TValue.Make(nil, TypeInfo, Value);
6199     ArrayData := @GetTypeData(TypeInfo).ArrayData;
6200     idx := 0;
6201     if ArrayData.DimCount = 1 then
6202     begin
6203       if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then
6204       begin
6205         Result := True;
6206         for i := 0 to ArrayData.ElCount - 1 do
6207         begin
6208           Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v);
6209           if not Result then
6210             Exit;
6211           Value.SetArrayElement(idx, v);
6212           v := TValue.Empty;
6213           inc(idx);
6214         end;
6215       end else
6216         Result := False;
6217     end else
6218       Result := ProcessDim(1, obj);
6219   end;
6220 
6221   procedure FromClassRef;
6222   var
6223     r: TRttiType;
6224   begin
6225     if ObjectIsType(obj, stString) then
6226     begin
6227       r := Context.FindType(obj.AsString);
6228       if r <> nil then
6229       begin
6230         Value := TRttiInstanceType(r).MetaclassType;
6231         Result := True;
6232       end else
6233         Result := False;
6234     end else
6235       Result := False;
6236   end;
6237 
6238   procedure FromUnknown;
6239   begin
6240     case ObjectGetType(obj) of
6241       stBoolean:
6242         begin
6243           Value := obj.AsBoolean;
6244           Result := True;
6245         end;
6246       stDouble:
6247         begin
6248           Value := obj.AsDouble;
6249           Result := True;
6250         end;
6251       stCurrency:
6252         begin
6253           Value := obj.AsCurrency;
6254           Result := True;
6255         end;
6256       stInt:
6257         begin
6258           Value := obj.AsInteger;
6259           Result := True;
6260         end;
6261       stString:
6262         begin
6263           Value := obj.AsString;
6264           Result := True;
6265         end
6266     else
6267       Value := nil;
6268       Result := False;
6269     end;
6270   end;
6271 
6272   procedure FromInterface;
6273   const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}';
6274   var
6275     o: ISuperObject;
6276   begin
6277     if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then
6278     begin
6279       if obj <> nil then
6280         TValue.Make(@obj, TypeInfo, Value) else
6281         begin
6282           o := TSuperObject.Create(stNull);
6283           TValue.Make(@o, TypeInfo, Value);
6284         end;
6285       Result := True;
6286     end else
6287       Result := False;
6288   end;
6289 var
6290   Serial: TSerialFromJson;
6291 begin
6292   if TypeInfo <> nil then
6293   begin
6294     if not SerialFromJson.TryGetValue(TypeInfo, Serial) then
6295       case TypeInfo.Kind of
6296         tkChar: FromChar;
6297         tkInt64: FromInt64;
6298         tkEnumeration, tkInteger: FromInt(obj);
6299         tkSet: fromSet;
6300         tkFloat: FromFloat(obj);
6301         tkString, tkLString, tkUString, tkWString: FromString;
6302         tkClass: FromClass;
6303         tkMethod: ;
6304         tkWChar: FromWideChar;
6305         tkRecord: FromRecord;
6306         tkPointer: ;
6307         tkInterface: FromInterface;
6308         tkArray: FromArray;
6309         tkDynArray: FromDynArray;
6310         tkClassRef: FromClassRef;
6311       else
6312         FromUnknown
6313       end else
6314       begin
6315         TValue.Make(nil, TypeInfo, Value);
6316         Result := Serial(Self, obj, Value);
6317       end;
6318   end else
6319     Result := False;
6320 end;
6321 
6322 function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject;
6323   procedure ToInt64;
6324   begin
6325     Result := TSuperObject.Create(SuperInt(Value.AsInt64));
6326   end;
6327 
6328   procedure ToChar;
6329   begin
6330     Result := TSuperObject.Create(string(Value.AsType));
6331   end;
6332 
6333   procedure ToInteger;
6334   begin
6335     Result := TSuperObject.Create(TValueData(Value).FAsSLong);
6336   end;
6337 
6338   procedure ToFloat;
6339   begin
6340     case Value.TypeData.FloatType of
6341       ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle);
6342       ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble);
6343       ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended);
6344       ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64);
6345       ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr);
6346     end;
6347   end;
6348 
6349   procedure ToString;
6350   begin
6351     Result := TSuperObject.Create(string(Value.AsType<string>));
6352   end;
6353 
6354   procedure ToClass;
6355   var
6356     o: ISuperObject;
6357     f: TRttiField;
6358     v: TValue;
6359   begin
6360     if TValueData(Value).FAsObject <> nil then
6361     begin
6362       o := index[IntToStr(Integer(Value.AsObject))];
6363       if o = nil then
6364       begin
6365         Result := TSuperObject.Create(stObject);
6366         index[IntToStr(Integer(Value.AsObject))] := Result;
6367         for f in Context.GetType(Value.AsObject.ClassType).GetFields do
6368           if f.FieldType <> nil then
6369           begin
6370             v := f.GetValue(Value.AsObject);
6371             Result.AsObject[GetFieldName(f)] := ToJson(v, index);
6372           end
6373       end else
6374         Result := o;
6375     end else
6376       Result := nil;
6377   end;
6378 
6379   procedure ToWChar;
6380   begin
6381     Result :=  TSuperObject.Create(string(Value.AsType));
6382   end;
6383 
6384   procedure ToVariant;
6385   begin
6386     Result := SO(Value.AsVariant);
6387   end;
6388 
6389   procedure ToRecord;
6390   var
6391     f: TRttiField;
6392     v: TValue;
6393   begin
6394     Result := TSuperObject.Create(stObject);
6395     for f in Context.GetType(Value.TypeInfo).GetFields do
6396     begin
6397       v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData);
6398       Result.AsObject[GetFieldName(f)] := ToJson(v, index);
6399     end;
6400   end;
6401 
6402   procedure ToArray;
6403   var
6404     idx: Integer;
6405     ArrayData: PArrayTypeData;
6406 
6407     procedure ProcessDim(dim: Byte; const o: ISuperObject);
6408     var
6409       dt: PTypeData;
6410       i: Integer;
6411       o2: ISuperObject;
6412       v: TValue;
6413     begin
6414       if ArrayData.Dims[dim-1] = nil then Exit;
6415       dt := GetTypeData(ArrayData.Dims[dim-1]^);
6416       if Dim = ArrayData.DimCount then
6417         for i := dt.MinValue to dt.MaxValue do
6418         begin
6419           v := Value.GetArrayElement(idx);
6420           o.AsArray.Add(toJSon(v, index));
6421           inc(idx);
6422         end
6423       else
6424         for i := dt.MinValue to dt.MaxValue do
6425         begin
6426           o2 := TSuperObject.Create(stArray);
6427           o.AsArray.Add(o2);
6428           ProcessDim(dim + 1, o2);
6429         end;
6430     end;
6431   var
6432     i: Integer;
6433     v: TValue;
6434   begin
6435     Result := TSuperObject.Create(stArray);
6436     ArrayData := @Value.TypeData.ArrayData;
6437     idx := 0;
6438     if ArrayData.DimCount = 1 then
6439       for i := 0 to ArrayData.ElCount - 1 do
6440       begin
6441         v := Value.GetArrayElement(i);
6442         Result.AsArray.Add(toJSon(v, index))
6443       end
6444     else
6445       ProcessDim(1, Result);
6446   end;
6447 
6448   procedure ToDynArray;
6449   var
6450     i: Integer;
6451     v: TValue;
6452   begin
6453     Result := TSuperObject.Create(stArray);
6454     for i := 0 to Value.GetArrayLength - 1 do
6455     begin
6456       v := Value.GetArrayElement(i);
6457       Result.AsArray.Add(toJSon(v, index));
6458     end;
6459   end;
6460 
6461   procedure ToClassRef;
6462   begin
6463     if TValueData(Value).FAsClass <> nil then
6464       Result :=  TSuperObject.Create(string(
6465         TValueData(Value).FAsClass.UnitName + '.' +
6466         TValueData(Value).FAsClass.ClassName)) else
6467       Result := nil;
6468   end;
6469 
6470   procedure ToInterface;
6471   begin
6472     if TValueData(Value).FHeapData <> nil then
6473       TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else
6474       Result := nil;
6475   end;
6476 
6477 var
6478   Serial: TSerialToJson;
6479 begin
6480   if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then
6481     case Value.Kind of
6482       tkInt64: ToInt64;
6483       tkChar: ToChar;
6484       tkSet, tkInteger, tkEnumeration: ToInteger;
6485       tkFloat: ToFloat;
6486       tkString, tkLString, tkUString, tkWString: ToString;
6487       tkClass: ToClass;
6488       tkWChar: ToWChar;
6489       tkVariant: ToVariant;
6490       tkRecord: ToRecord;
6491       tkArray: ToArray;
6492       tkDynArray: ToDynArray;
6493       tkClassRef: ToClassRef;
6494       tkInterface: ToInterface;
6495     else
6496       result := nil;
6497     end else
6498       Result := Serial(Self, value, index);
6499 end;
6500 
6501 { TSuperObjectHelper }
6502 
6503 constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil);
6504 var
6505   v: TValue;
6506   ctxowned: Boolean;
6507 begin
6508   if ctx = nil then
6509   begin
6510     ctx := TSuperRttiContext.Create;
6511     ctxowned := True;
6512   end else
6513     ctxowned := False;
6514   try
6515     v := Self;
6516     if not ctx.FromJson(v.TypeInfo, obj, v) then
6517       raise Exception.Create('Invalid object');
6518   finally
6519     if ctxowned then
6520       ctx.Free;
6521   end;
6522 end;
6523 
6524 constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil);
6525 begin
6526   FromJson(SO(str), ctx);
6527 end;
6528 
6529 function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
6530 var
6531   v: TValue;
6532   ctxowned: boolean;
6533 begin
6534   if ctx = nil then
6535   begin
6536     ctx := TSuperRttiContext.Create;
6537     ctxowned := True;
6538   end else
6539     ctxowned := False;
6540   try
6541     v := Self;
6542     Result := ctx.ToJson(v, SO);
6543   finally
6544     if ctxowned then
6545       ctx.Free;
6546   end;
6547 end;
6548 
6549 {$ENDIF}
6550 
6551 {$IFDEF DEBUG}
6552 initialization
6553 
6554 finalization
6555   Assert(debugcount = 0, 'Memory leak');
6556 {$ENDIF}
6557 end.

View Code