阿里大于是阿里通信旗下产品，融合了三大运营商的通信能力，提供包括短信、语音、流量直充、私密专线、店铺手机号等个性化服务。每条四分五，价钱还算公道，经老农测试，响应速度非常快，基本上是秒到。官方文档提供了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 /// <author>全能地图（QQ：64445322）</author>
50 /// <summary>
51 /// 利用阿里大于接口发短信
52 /// 阿里大于网址：http://www.alidayu.com
53 /// 阿里大于短信接口文档：https://api.alidayu.com/doc2/apiDetail.htm?apiId=25450
54 /// </summary>
55 /// <param name="AppKey">TOP分配给应用的AppKey</param>
56 /// <param name="AppSecret">AppSecret</param>
57 /// <param name="ReceiveNumber">接收手机号码</param>
58 /// <param name="FreeSignName">短信签名，传入的短信签名必须是在阿里大于“管理中心-短信签名管理”中的可用签名</param>
59 /// <param name="TemplateCode">短信模板ID</param>
60 /// <param name="TemplateContent">短信模板变量，例如：{"code":"1234","product":"alidayu"}</param>
61 /// <param name="ResultMsg">下发结果消息</param>
62 /// <returns>是否成功，True = 成功 ，false = 失败</returns>
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 /// <author>全能地图（QQ：64445322）</author>
2 /// <summary>
3 /// 利用阿里大于接口发短信
4 /// 阿里大于网址：http://www.alidayu.com
5 /// 阿里大于短信接口文档：https://api.alidayu.com/doc2/apiDetail.htm?apiId=25450
6 /// </summary>
7 /// <param name="AppKey">TOP分配给应用的AppKey</param>
8 /// <param name="AppSecret">AppSecret</param>
9 /// <param name="ReceiveNumber">接收手机号码</param>
10 /// <param name="FreeSignName">短信签名，传入的短信签名必须是在阿里大于“管理中心-短信签名管理”中的可用签名</param>
11 /// <param name="TemplateCode">短信模板ID</param>
12 /// <param name="TemplateContent">短信模板变量，例如：{"code":"1234","product":"alidayu"}</param>
13 /// <param name="ResultMsg">下发结果消息</param>
14 /// <returns>是否成功，True = 成功 ，false = 失败</returns>
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 <hgourvest@gmail.com>
12 * Web site : http://www.progdigy.com
13 *
14 * This unit is inspired from the json c lib:
15 * Michael Clark <michael@metaparadigm.com>
16 * http://oss.metaparadigm.com/json-c/
17 *
18 * CHANGES:
19 * v1.2
20 * + support of currency data type
21 * + right trim unquoted string
22 * + read Unicode Files and streams (Litle Endian with BOM)
23 * + Fix bug on javadate functions + windows nt compatibility
24 * + Now you can force to parse only the canonical syntax of JSON using the stric parameter
25 * + Delphi 2010 RTTI marshalling
26 * v1.1
27 * + Double licence MPL or LGPL.
28 * + Delphi 2009 compatibility & Unicode support.
29 * + AsString return a string instead of PChar.
30 * + Escaped and Unascaped JSON serialiser.
31 * + Missed FormFeed added \f
32 * - Removed @ trick, uses forcepath() method instead.
33 * + Fixed parse error with uppercase E symbol in numbers.
34 * + Fixed possible buffer overflow when enlarging array.
35 * + Added "delete", "pack", "insert" methods for arrays and/or objects
36 * + Multi parametters when calling methods
37 * + Delphi Enumerator (for obj1 in obj2 do ...)
38 * + Format method ex: obj.format('<%name%>%tab[1]%</%name%>')
39 * + ParseFile and ParseStream methods
40 * + Parser now understand hexdecimal c syntax ex: \xFF
41 * + Null Object Design Patern (ex: for obj in values.N['path'] do ...)
42 * v1.0
43 * + renamed class
44 * + interfaced object
45 * + added a new data type: the method
46 * + parser can now evaluate properties and call methods
47 * - removed obselet rpc class
48 * - removed "find" method, now you can use "parse" method instead
49 * v0.6
50 * + refactoring
51 * v0.5
52 * + new find method to get or set value using a path syntax
53 * ex: obj.s['obj.prop[1]'] := 'string value';
54 * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary
55 * v0.4
56 * + bug corrected: AVL tree badly balanced.
57 * v0.3
58 * + New validator partially based on the Kwalify syntax.
59 * + extended syntax to parse unquoted fields.
60 * + Freepascal compatibility win32/64 Linux32/64.
61 * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC.
62 * + new TJsonObject.Compare function.
63 * v0.2
64 * + Hashed string list replaced with a faster AVL tree
65 * + JsonInt data type can be changed to int64
66 * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions
67 * + from json-c v0.7
68 * + Add escaping of backslash to json output
69 * + Add escaping of foward slash on tokenizing and output
70 * + Changes to internal tokenizer from using recursion to
71 * using a depth state structure to allow incremental parsing
72 * v0.1
73 * + first release
74 *)
75
76 {$IFDEF FPC}
77 {$MODE OBJFPC}{$H+}
78 {$ENDIF}
79
80 {$DEFINE SUPER_METHOD}
81 {$DEFINE WINDOWSNT_COMPATIBILITY}
82 {.$DEFINE DEBUG} // track memory leack
83
84 unit superobject;
85
86 interface
87 uses
88 Classes
89 {$IFDEF VER210}
90 ,Generics.Collections, RTTI, TypInfo
91 {$ENDIF}
92 ;
93
94 type
95 {$IFNDEF FPC}
96 PtrInt = longint;
97 PtrUInt = Longword;
98 {$ENDIF}
99 SuperInt = Int64;
100
101 {$if (sizeof(Char) = 1)}
102 SOChar = WideChar;
103 SOIChar = Word;
104 PSOChar = PWideChar;
105 SOString = WideString;
106 {$else}
107 SOChar = Char;
108 SOIChar = Word;
109 PSOChar = PChar;
110 SOString = string;
111 {$ifend}
112
113 const
114 SUPER_ARRAY_LIST_DEFAULT_SIZE = 32;
115 SUPER_TOKENER_MAX_DEPTH = 32;
116
117 SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8;
118 SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1);
119
120 type
121 // forward declarations
122 TSuperObject = class;
123 ISuperObject = interface;
124 TSuperArray = class;
125
126 (* AVL Tree
127 * This is a "special" autobalanced AVL tree
128 * It use a hash value for fast compare
129 *)
130
131 {$IFDEF SUPER_METHOD}
132 TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject);
133 {$ENDIF}
134
135
136 TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1;
137
138 TSuperAvlSearchType = (stEQual, stLess, stGreater);
139 TSuperAvlSearchTypes = set of TSuperAvlSearchType;
140 TSuperAvlIterator = class;
141
142 TSuperAvlEntry = class
143 private
144 FGt, FLt: TSuperAvlEntry;
145 FBf: integer;
146 FHash: Cardinal;
147 FName: SOString;
148 FPtr: Pointer;
149 function GetValue: ISuperObject;
150 procedure SetValue(const val: ISuperObject);
151 public
152 class function Hash(const k: SOString): Cardinal; virtual;
153 constructor Create(const AName: SOString; Obj: Pointer); virtual;
154 property Name: SOString read FName;
155 property Ptr: Pointer read FPtr;
156 property Value: ISuperObject read GetValue write SetValue;
157 end;
158
159 TSuperAvlTree = class
160 private
161 FRoot: TSuperAvlEntry;
162 FCount: Integer;
163 function balance(bal: TSuperAvlEntry): TSuperAvlEntry;
164 protected
165 procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual;
166 function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual;
167 function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual;
168 function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual;
169 function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual;
170 public
171 constructor Create; virtual;
172 destructor Destroy; override;
173 function IsEmpty: boolean;
174 procedure Clear(all: boolean = false); virtual;
175 procedure Pack(all: boolean);
176 function Delete(const k: SOString): ISuperObject;
177 function GetEnumerator: TSuperAvlIterator;
178 property count: Integer read FCount;
179 end;
180
181 TSuperTableString = class(TSuperAvlTree)
182 protected
183 procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override;
184 procedure PutO(const k: SOString; const value: ISuperObject);
185 function GetO(const k: SOString): ISuperObject;
186 procedure PutS(const k: SOString; const value: SOString);
187 function GetS(const k: SOString): SOString;
188 procedure PutI(const k: SOString; value: SuperInt);
189 function GetI(const k: SOString): SuperInt;
190 procedure PutD(const k: SOString; value: Double);
191 function GetD(const k: SOString): Double;
192 procedure PutB(const k: SOString; value: Boolean);
193 function GetB(const k: SOString): Boolean;
194 {$IFDEF SUPER_METHOD}
195 procedure PutM(const k: SOString; value: TSuperMethod);
196 function GetM(const k: SOString): TSuperMethod;
197 {$ENDIF}
198 procedure PutN(const k: SOString; const value: ISuperObject);
199 function GetN(const k: SOString): ISuperObject;
200 procedure PutC(const k: SOString; value: Currency);
201 function GetC(const k: SOString): Currency;
202 public
203 property O[const k: SOString]: ISuperObject read GetO write PutO; default;
204 property S[const k: SOString]: SOString read GetS write PutS;
205 property I[const k: SOString]: SuperInt read GetI write PutI;
206 property D[const k: SOString]: Double read GetD write PutD;
207 property B[const k: SOString]: Boolean read GetB write PutB;
208 {$IFDEF SUPER_METHOD}
209 property M[const k: SOString]: TSuperMethod read GetM write PutM;
210 {$ENDIF}
211 property N[const k: SOString]: ISuperObject read GetN write PutN;
212 property C[const k: SOString]: Currency read GetC write PutC;
213
214 function GetValues: ISuperObject;
215 function GetNames: ISuperObject;
216 end;
217
218 TSuperAvlIterator = class
219 private
220 FTree: TSuperAvlTree;
221 FBranch: TSuperAvlBitArray;
222 FDepth: LongInt;
223 FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry;
224 public
225 constructor Create(tree: TSuperAvlTree); virtual;
226 procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]);
227 procedure First;
228 procedure Last;
229 function GetIter: TSuperAvlEntry;
230 procedure Next;
231 procedure Prior;
232 // delphi enumerator
233 function MoveNext: Boolean;
234 property Current: TSuperAvlEntry read GetIter;
235 end;
236
237 TSuperObjectArray = array[0..(high(PtrInt) div sizeof(TSuperObject))-1] of ISuperObject;
238 PSuperObjectArray = ^TSuperObjectArray;
239
240 TSuperArray = class
241 private
242 FArray: PSuperObjectArray;
243 FLength: Integer;
244 FSize: Integer;
245 procedure Expand(max: Integer);
246 protected
247 function GetO(const index: integer): ISuperObject;
248 procedure PutO(const index: integer; const Value: ISuperObject);
249 function GetB(const index: integer): Boolean;
250 procedure PutB(const index: integer; Value: Boolean);
251 function GetI(const index: integer): SuperInt;
252 procedure PutI(const index: integer; Value: SuperInt);
253 function GetD(const index: integer): Double;
254 procedure PutD(const index: integer; Value: Double);
255 function GetC(const index: integer): Currency;
256 procedure PutC(const index: integer; Value: Currency);
257 function GetS(const index: integer): SOString;
258 procedure PutS(const index: integer; const Value: SOString);
259 {$IFDEF SUPER_METHOD}
260 function GetM(const index: integer): TSuperMethod;
261 procedure PutM(const index: integer; Value: TSuperMethod);
262 {$ENDIF}
263 function GetN(const index: integer): ISuperObject;
264 procedure PutN(const index: integer; const Value: ISuperObject);
265 public
266 constructor Create; virtual;
267 destructor Destroy; override;
268 function Add(const Data: ISuperObject): Integer;
269 function Delete(index: Integer): ISuperObject;
270 procedure Insert(index: Integer; const value: ISuperObject);
271 procedure Clear(all: boolean = false);
272 procedure Pack(all: boolean);
273 property Length: Integer read FLength;
274
275 property N[const index: integer]: ISuperObject read GetN write PutN;
276 property O[const index: integer]: ISuperObject read GetO write PutO; default;
277 property B[const index: integer]: boolean read GetB write PutB;
278 property I[const index: integer]: SuperInt read GetI write PutI;
279 property D[const index: integer]: Double read GetD write PutD;
280 property C[const index: integer]: Currency read GetC write PutC;
281 property S[const index: integer]: SOString read GetS write PutS;
282 {$IFDEF SUPER_METHOD}
283 property M[const index: integer]: TSuperMethod read GetM write PutM;
284 {$ENDIF}
285 // property A[const index: integer]: TSuperArray read GetA;
286 end;
287
288 TSuperWriter = class
289 public
290 // abstact methods to overide
291 function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract;
292 function Append(buf: PSOChar): Integer; overload; virtual; abstract;
293 procedure Reset; virtual; abstract;
294 end;
295
296 TSuperWriterString = class(TSuperWriter)
297 private
298 FBuf: PSOChar;
299 FBPos: integer;
300 FSize: integer;
301 public
302 function Append(buf: PSOChar; Size: Integer): Integer; overload; override;
303 function Append(buf: PSOChar): Integer; overload; override;
304 procedure Reset; override;
305 procedure TrimRight;
306 constructor Create; virtual;
307 destructor Destroy; override;
308 function GetString: SOString;
309 property Data: PSOChar read FBuf;
310 property Size: Integer read FSize;
311 property Position: integer read FBPos;
312 end;
313
314 TSuperWriterStream = class(TSuperWriter)
315 private
316 FStream: TStream;
317 public
318 function Append(buf: PSOChar): Integer; override;
319 procedure Reset; override;
320 constructor Create(AStream: TStream); reintroduce; virtual;
321 end;
322
323 TSuperAnsiWriterStream = class(TSuperWriterStream)
324 public
325 function Append(buf: PSOChar; Size: Integer): Integer; override;
326 end;
327
328 TSuperUnicodeWriterStream = class(TSuperWriterStream)
329 public
330 function Append(buf: PSOChar; Size: Integer): Integer; override;
331 end;
332
333 TSuperWriterFake = class(TSuperWriter)
334 private
335 FSize: Integer;
336 public
337 function Append(buf: PSOChar; Size: Integer): Integer; override;
338 function Append(buf: PSOChar): Integer; override;
339 procedure Reset; override;
340 constructor Create; reintroduce; virtual;
341 property size: integer read FSize;
342 end;
343
344 TSuperWriterSock = class(TSuperWriter)
345 private
346 FSocket: longint;
347 FSize: Integer;
348 public
349 function Append(buf: PSOChar; Size: Integer): Integer; override;
350 function Append(buf: PSOChar): Integer; override;
351 procedure Reset; override;
352 constructor Create(ASocket: longint); reintroduce; virtual;
353 property Socket: longint read FSocket;
354 property Size: Integer read FSize;
355 end;
356
357 TSuperTokenizerError = (
358 teSuccess,
359 teContinue,
360 teDepth,
361 teParseEof,
362 teParseUnexpected,
363 teParseNull,
364 teParseBoolean,
365 teParseNumber,
366 teParseArray,
367 teParseObjectKeyName,
368 teParseObjectKeySep,
369 teParseObjectValueSep,
370 teParseString,
371 teParseComment,
372 teEvalObject,
373 teEvalArray,
374 teEvalMethod,
375 teEvalInt
376 );
377
378 TSuperTokenerState = (
379 tsEatws,
380 tsStart,
381 tsFinish,
382 tsNull,
383 tsCommentStart,
384 tsComment,
385 tsCommentEol,
386 tsCommentEnd,
387 tsString,
388 tsStringEscape,
389 tsIdentifier,
390 tsEscapeUnicode,
391 tsEscapeHexadecimal,
392 tsBoolean,
393 tsNumber,
394 tsArray,
395 tsArrayAdd,
396 tsArraySep,
397 tsObjectFieldStart,
398 tsObjectField,
399 tsObjectUnquotedField,
400 tsObjectFieldEnd,
401 tsObjectValue,
402 tsObjectValueAdd,
403 tsObjectSep,
404 tsEvalProperty,
405 tsEvalArray,
406 tsEvalMethod,
407 tsParamValue,
408 tsParamPut,
409 tsMethodValue,
410 tsMethodPut
411 );
412
413 PSuperTokenerSrec = ^TSuperTokenerSrec;
414 TSuperTokenerSrec = record
415 state, saved_state: TSuperTokenerState;
416 obj: ISuperObject;
417 current: ISuperObject;
418 field_name: SOString;
419 parent: ISuperObject;
420 gparent: ISuperObject;
421 end;
422
423 TSuperTokenizer = class
424 public
425 str: PSOChar;
426 pb: TSuperWriterString;
427 depth, is_double, floatcount, st_pos, char_offset: Integer;
428 err: TSuperTokenizerError;
429 ucs_char: Word;
430 quote_char: SOChar;
431 stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec;
432 line, col: Integer;
433 public
434 constructor Create; virtual;
435 destructor Destroy; override;
436 procedure ResetLevel(adepth: integer);
437 procedure Reset;
438 end;
439
440 // supported object types
441 TSuperType = (
442 stNull,
443 stBoolean,
444 stDouble,
445 stCurrency,
446 stInt,
447 stObject,
448 stArray,
449 stString
450 {$IFDEF SUPER_METHOD}
451 ,stMethod
452 {$ENDIF}
453 );
454
455 TSuperValidateError = (
456 veRuleMalformated,
457 veFieldIsRequired,
458 veInvalidDataType,
459 veFieldNotFound,
460 veUnexpectedField,
461 veDuplicateEntry,
462 veValueNotInEnum,
463 veInvalidLength,
464 veInvalidRange
465 );
466
467 TSuperFindOption = (
468 foCreatePath,
469 foPutValue,
470 foDelete
471 {$IFDEF SUPER_METHOD}
472 ,foCallMethod
473 {$ENDIF}
474 );
475
476 TSuperFindOptions = set of TSuperFindOption;
477 TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError);
478 TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString);
479
480 TSuperEnumerator = class
481 private
482 FObj: ISuperObject;
483 FObjEnum: TSuperAvlIterator;
484 FCount: Integer;
485 public
486 constructor Create(const obj: ISuperObject); virtual;
487 destructor Destroy; override;
488 function MoveNext: Boolean;
489 function GetCurrent: ISuperObject;
490 property Current: ISuperObject read GetCurrent;
491 end;
492
493 ISuperObject = interface
494 ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}']
495 function GetEnumerator: TSuperEnumerator;
496 function GetDataType: TSuperType;
497 function GetProcessing: boolean;
498 procedure SetProcessing(value: boolean);
499 function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
500 function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
501
502 function GetO(const path: SOString): ISuperObject;
503 procedure PutO(const path: SOString; const Value: ISuperObject);
504 function GetB(const path: SOString): Boolean;
505 procedure PutB(const path: SOString; Value: Boolean);
506 function GetI(const path: SOString): SuperInt;
507 procedure PutI(const path: SOString; Value: SuperInt);
508 function GetD(const path: SOString): Double;
509 procedure PutC(const path: SOString; Value: Currency);
510 function GetC(const path: SOString): Currency;
511 procedure PutD(const path: SOString; Value: Double);
512 function GetS(const path: SOString): SOString;
513 procedure PutS(const path: SOString; const Value: SOString);
514 {$IFDEF SUPER_METHOD}
515 function GetM(const path: SOString): TSuperMethod;
516 procedure PutM(const path: SOString; Value: TSuperMethod);
517 {$ENDIF}
518 function GetA(const path: SOString): TSuperArray;
519
520 // Null Object Design patern
521 function GetN(const path: SOString): ISuperObject;
522 procedure PutN(const path: SOString; const Value: ISuperObject);
523
524 // Writers
525 function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
526 function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
527 function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
528 function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
529 function CalcSize(indent: boolean = false; escape: boolean = true): integer;
530
531 // convert
532 function AsBoolean: Boolean;
533 function AsInteger: SuperInt;
534 function AsDouble: Double;
535 function AsCurrency: Currency;
536 function AsString: SOString;
537 function AsArray: TSuperArray;
538 function AsObject: TSuperTableString;
539 {$IFDEF SUPER_METHOD}
540 function AsMethod: TSuperMethod;
541 {$ENDIF}
542 function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
543
544 procedure Clear(all: boolean = false);
545 procedure Pack(all: boolean = false);
546
547 property N[const path: SOString]: ISuperObject read GetN write PutN;
548 property O[const path: SOString]: ISuperObject read GetO write PutO; default;
549 property B[const path: SOString]: boolean read GetB write PutB;
550 property I[const path: SOString]: SuperInt read GetI write PutI;
551 property D[const path: SOString]: Double read GetD write PutD;
552 property C[const path: SOString]: Currency read GetC write PutC;
553 property S[const path: SOString]: SOString read GetS write PutS;
554 {$IFDEF SUPER_METHOD}
555 property M[const path: SOString]: TSuperMethod read GetM write PutM;
556 {$ENDIF}
557 property A[const path: SOString]: TSuperArray read GetA;
558
559 {$IFDEF SUPER_METHOD}
560 function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload;
561 function call(const path, param: SOString): ISuperObject; overload;
562 {$ENDIF}
563 // clone a node
564 function Clone: ISuperObject;
565 function Delete(const path: SOString): ISuperObject;
566 // merges tow objects of same type, if reference is true then nodes are not cloned
567 procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
568 procedure Merge(const str: SOString); overload;
569
570 // validate methods
571 function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
572 function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
573
574 // compare
575 function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
576 function Compare(const str: SOString): TSuperCompareResult; overload;
577
578 // the data type
579 function IsType(AType: TSuperType): boolean;
580 property DataType: TSuperType read GetDataType;
581 property Processing: boolean read GetProcessing write SetProcessing;
582
583 function GetDataPtr: Pointer;
584 procedure SetDataPtr(const Value: Pointer);
585 property DataPtr: Pointer read GetDataPtr write SetDataPtr;
586 end;
587
588 TSuperObject = class(TObject, ISuperObject)
589 private
590 FRefCount: Integer;
591 FProcessing: boolean;
592 FDataType: TSuperType;
593 FDataPtr: Pointer;
594 {.$if true}
595 FO: record
596 case TSuperType of
597 stBoolean: (c_boolean: boolean);
598 stDouble: (c_double: double);
599 stCurrency: (c_currency: Currency);
600 stInt: (c_int: SuperInt);
601 stObject: (c_object: TSuperTableString);
602 stArray: (c_array: TSuperArray);
603 {$IFDEF SUPER_METHOD}
604 stMethod: (c_method: TSuperMethod);
605 {$ENDIF}
606 end;
607 {.$ifend}
608 FOString: SOString;
609 function GetDataType: TSuperType;
610 function GetDataPtr: Pointer;
611 procedure SetDataPtr(const Value: Pointer);
612 protected
613 function QueryInterface(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<PTypeInfo, TSerialFromJson>;
756 SerialToJson: TDictionary<PTypeInfo, TSerialToJson>;
757 constructor Create; virtual;
758 destructor Destroy; override;
759 function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual;
760 function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual;
761 function AsType<T>(const obj: ISuperObject): T;
762 function AsJson<T>(const obj: T; const index: ISuperObject = nil): ISuperObject;
763 end;
764
765 TSuperObjectHelper = class helper for TObject
766 public
767 function ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
768 constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload;
769 constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload;
770 end;
771 {$ENDIF}
772
773 TSuperObjectIter = record
774 key: SOString;
775 val: ISuperObject;
776 Ite: TSuperAvlIterator;
777 end;
778
779 function ObjectIsError(obj: TSuperObject): boolean;
780 function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
781 function ObjectGetType(const obj: ISuperObject): TSuperType;
782
783 function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
784 function ObjectFindNext(var F: TSuperObjectIter): boolean;
785 procedure ObjectFindClose(var F: TSuperObjectIter);
786
787 function SO(const s: SOString = '{}'): ISuperObject; overload;
788 function SO(const value: Variant): ISuperObject; overload;
789 function SO(const Args: array of const): ISuperObject; overload;
790
791 function SA(const Args: array of const): ISuperObject; overload;
792
793 function JavaToDelphiDateTime(const dt: int64): TDateTime;
794 function DelphiToJavaDateTime(const dt: TDateTime): int64;
795
796 {$IFDEF VER210}
797
798 type
799 TSuperInvokeResult = (
800 irSuccess,
801 irMethothodError, // method don't exist
802 irParamError, // invalid parametters
803 irError // other error
804 );
805
806 function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload;
807 function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload;
808 function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload;
809 {$ENDIF}
810
811 implementation
812 uses sysutils,
813 {$IFDEF UNIX}
814 baseunix, unix, DateUtils
815 {$ELSE}
816 Windows
817 {$ENDIF}
818 {$IFDEF FPC}
819 ,sockets
820 {$ELSE}
821 ,WinSock
822 {$ENDIF};
823
824 {$IFDEF DEBUG}
825 var
826 debugcount: integer = 0;
827 {$ENDIF}
828
829 const
830 super_number_chars_set = ['0'..'9','.','+','-','e','E'];
831 super_hex_chars: PSOChar = '0123456789abcdef';
832 super_hex_chars_set = ['0'..'9','a'..'f','A'..'F'];
833
834 ESC_BS: PSOChar = '\b';
835 ESC_LF: PSOChar = '\n';
836 ESC_CR: PSOChar = '\r';
837 ESC_TAB: PSOChar = '\t';
838 ESC_FF: PSOChar = '\f';
839 ESC_QUOT: PSOChar = '\"';
840 ESC_SL: PSOChar = '\\';
841 ESC_SR: PSOChar = '\/';
842 ESC_ZERO: PSOChar = '\u0000';
843
844 TOK_CRLF: PSOChar = #13#10;
845 TOK_SP: PSOChar = #32;
846 TOK_BS: PSOChar = #8;
847 TOK_TAB: PSOChar = #9;
848 TOK_LF: PSOChar = #10;
849 TOK_FF: PSOChar = #12;
850 TOK_CR: PSOChar = #13;
851 // TOK_SL: PSOChar = '\';
852 // TOK_SR: PSOChar = '/';
853 TOK_NULL: PSOChar = 'null';
854 TOK_CBL: PSOChar = '{'; // curly bracket left
855 TOK_CBR: PSOChar = '}'; // curly bracket right
856 TOK_ARL: PSOChar = '[';
857 TOK_ARR: PSOChar = ']';
858 TOK_ARRAY: PSOChar = '[]';
859 TOK_OBJ: PSOChar = '{}'; // empty object
860 TOK_COM: PSOChar = ','; // Comma
861 TOK_DQT: PSOChar = '"'; // Double Quote
862 TOK_TRUE: PSOChar = 'true';
863 TOK_FALSE: PSOChar = 'false';
864
865 {$if (sizeof(Char) = 1)}
866 function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer;
867 var
868 P1, P2: PWideChar;
869 I: Cardinal;
870 C1, C2: WideChar;
871 begin
872 P1 := Str1;
873 P2 := Str2;
874 I := 0;
875 while I < MaxLen do
876 begin
877 C1 := P1^;
878 C2 := P2^;
879
880 if (C1 <> C2) or (C1 = #0) then
881 begin
882 Result := Ord(C1) - Ord(C2);
883 Exit;
884 end;
885
886 Inc(P1);
887 Inc(P2);
888 Inc(I);
889 end;
890 Result := 0;
891 end;
892
893 function StrComp(const Str1, Str2: PSOChar): Integer;
894 var
895 P1, P2: PWideChar;
896 C1, C2: WideChar;
897 begin
898 P1 := Str1;
899 P2 := Str2;
900 while True do
901 begin
902 C1 := P1^;
903 C2 := P2^;
904
905 if (C1 <> C2) or (C1 = #0) then
906 begin
907 Result := Ord(C1) - Ord(C2);
908 Exit;
909 end;
910
911 Inc(P1);
912 Inc(P2);
913 end;
914 end;
915
916 function StrLen(const Str: PSOChar): Cardinal;
917 var
918 p: PSOChar;
919 begin
920 Result := 0;
921 if Str <> nil then
922 begin
923 p := Str;
924 while p^ <> #0 do inc(p);
925 Result := (p - Str);
926 end;
927 end;
928 {$ifend}
929
930 function CurrToStr(c: Currency): SOString;
931 var
932 p: PSOChar;
933 i, len: Integer;
934 begin
935 Result := IntToStr(Abs(PInt64(@c)^));
936 len := Length(Result);
937 SetLength(Result, len+1);
938 if c <> 0 then
939 begin
940 while len <= 4 do
941 begin
942 Result := '0' + Result;
943 inc(len);
944 end;
945
946 p := PSOChar(Result);
947 inc(p, len-1);
948 i := 0;
949 repeat
950 if p^ <> '0' then
951 begin
952 len := len - i + 1;
953 repeat
954 p[1] := p^;
955 dec(p);
956 inc(i);
957 until i > 3;
958 Break;
959 end;
960 dec(p);
961 inc(i);
962 if i > 3 then
963 begin
964 len := len - i + 1;
965 Break;
966 end;
967 until false;
968 p[1] := '.';
969 SetLength(Result, len);
970 if c < 0 then
971 Result := '-' + Result;
972 end;
973 end;
974
975 {$IFDEF UNIX}
976 {$linklib c}
977 {$ENDIF}
978 function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl;
979 external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF};
980
981 {$IFDEF UNIX}
982 type
983 ptm = ^tm;
984 tm = record
985 tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *)
986 tm_min: Integer; (* Minutes: 0-59 *)
987 tm_hour: Integer; (* Hours since midnight: 0-23 *)
988 tm_mday: Integer; (* Day of the month: 1-31 *)
989 tm_mon: Integer; (* Months *since* january: 0-11 *)
990 tm_year: Integer; (* Years since 1900 *)
991 tm_wday: Integer; (* Days since Sunday (0-6) *)
992 tm_yday: Integer; (* Days since Jan. 1: 0-365 *)
993 tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *)
994 end;
995
996 function mktime(p: ptm): LongInt; cdecl; external;
997 function gmtime(const t: PLongint): ptm; cdecl; external;
998 function localtime (const t: PLongint): ptm; cdecl; external;
999
1000 function DelphiToJavaDateTime(const dt: TDateTime): Int64;
1001 var
1002 p: ptm;
1003 l, ms: Integer;
1004 v: Int64;
1005 begin
1006 v := Round((dt - 25569) * 86400000);
1007 ms := v mod 1000;
1008 l := v div 1000;
1009 p := localtime(@l);
1010 Result := Int64(mktime(p)) * 1000 + ms;
1011 end;
1012
1013 function JavaToDelphiDateTime(const dt: int64): TDateTime;
1014 var
1015 p: ptm;
1016 l, ms: Integer;
1017 begin
1018 l := dt div 1000;
1019 ms := dt mod 1000;
1020 p := gmtime(@l);
1021 Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms);
1022 end;
1023 {$ELSE}
1024
1025 {$IFDEF WINDOWSNT_COMPATIBILITY}
1026 function DayLightCompareDate(const date: PSystemTime;
1027 const compareDate: PSystemTime): Integer;
1028 var
1029 limit_day, dayinsecs, weekofmonth: Integer;
1030 First: Word;
1031 begin
1032 if (date^.wMonth < compareDate^.wMonth) then
1033 begin
1034 Result := -1; (* We are in a month before the date limit. *)
1035 Exit;
1036 end;
1037
1038 if (date^.wMonth > compareDate^.wMonth) then
1039 begin
1040 Result := 1; (* We are in a month after the date limit. *)
1041 Exit;
1042 end;
1043
1044 (* if year is 0 then date is in day-of-week format, otherwise
1045 * it's absolute date.
1046 *)
1047 if (compareDate^.wYear = 0) then
1048 begin
1049 (* compareDate.wDay is interpreted as number of the week in the month
1050 * 5 means: the last week in the month *)
1051 weekofmonth := compareDate^.wDay;
1052 (* calculate the day of the first DayOfWeek in the month *)
1053 First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1;
1054 limit_day := First + 7 * (weekofmonth - 1);
1055 (* check needed for the 5th weekday of the month *)
1056 if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth - 1]) then
1057 dec(limit_day, 7);
1058 end
1059 else
1060 limit_day := compareDate^.wDay;
1061
1062 (* convert to seconds *)
1063 limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60;
1064 dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond;
1065 (* and compare *)
1066
1067 if dayinsecs < limit_day then
1068 Result := -1 else
1069 if dayinsecs > limit_day then
1070 Result := 1 else
1071 Result := 0; (* date is equal to the date limit. *)
1072 end;
1073
1074 function CompTimeZoneID(const pTZinfo: PTimeZoneInformation;
1075 lpFileTime: PFileTime; islocal: Boolean): LongWord;
1076 var
1077 ret: Integer;
1078 beforeStandardDate, afterDaylightDate: Boolean;
1079 llTime: Int64;
1080 SysTime: TSystemTime;
1081 ftTemp: TFileTime;
1082 begin
1083 llTime := 0;
1084
1085 if (pTZinfo^.DaylightDate.wMonth <> 0) then
1086 begin
1087 (* if year is 0 then date is in day-of-week format, otherwise
1088 * it's absolute date.
1089 *)
1090 if ((pTZinfo^.StandardDate.wMonth = 0) or
1091 ((pTZinfo^.StandardDate.wYear = 0) and
1092 ((pTZinfo^.StandardDate.wDay < 1) or
1093 (pTZinfo^.StandardDate.wDay > 5) or
1094 (pTZinfo^.DaylightDate.wDay < 1) or
1095 (pTZinfo^.DaylightDate.wDay > 5)))) then
1096 begin
1097 SetLastError(ERROR_INVALID_PARAMETER);
1098 Result := TIME_ZONE_ID_INVALID;
1099 Exit;
1100 end;
1101
1102 if (not islocal) then
1103 begin
1104 llTime := PInt64(lpFileTime)^;
1105 dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000);
1106 PInt64(@ftTemp)^ := llTime;
1107 lpFileTime := @ftTemp;
1108 end;
1109
1110 FileTimeToSystemTime(lpFileTime^, SysTime);
1111
1112 (* check for daylight savings *)
1113 ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate);
1114 if (ret = -2) then
1115 begin
1116 Result := TIME_ZONE_ID_INVALID;
1117 Exit;
1118 end;
1119
1120 beforeStandardDate := ret < 0;
1121
1122 if (not islocal) then
1123 begin
1124 dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000);
1125 PInt64(@ftTemp)^ := llTime;
1126 FileTimeToSystemTime(lpFileTime^, SysTime);
1127 end;
1128
1129 ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate);
1130 if (ret = -2) then
1131 begin
1132 Result := TIME_ZONE_ID_INVALID;
1133 Exit;
1134 end;
1135
1136 afterDaylightDate := ret >= 0;
1137
1138 Result := TIME_ZONE_ID_STANDARD;
1139 if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then
1140 begin
1141 (* Northern hemisphere *)
1142 if( beforeStandardDate and afterDaylightDate) then
1143 Result := TIME_ZONE_ID_DAYLIGHT;
1144 end else (* Down south *)
1145 if( beforeStandardDate or afterDaylightDate) then
1146 Result := TIME_ZONE_ID_DAYLIGHT;
1147 end else
1148 (* No transition date *)
1149 Result := TIME_ZONE_ID_UNKNOWN;
1150 end;
1151
1152 function GetTimezoneBias(const pTZinfo: PTimeZoneInformation;
1153 lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean;
1154 var
1155 bias: LongInt;
1156 tzid: LongWord;
1157 begin
1158 bias := pTZinfo^.Bias;
1159 tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal);
1160
1161 if( tzid = TIME_ZONE_ID_INVALID) then
1162 begin
1163 Result := False;
1164 Exit;
1165 end;
1166 if (tzid = TIME_ZONE_ID_DAYLIGHT) then
1167 inc(bias, pTZinfo^.DaylightBias)
1168 else if (tzid = TIME_ZONE_ID_STANDARD) then
1169 inc(bias, pTZinfo^.StandardBias);
1170 pBias^ := bias;
1171 Result := True;
1172 end;
1173
1174 function SystemTimeToTzSpecificLocalTime(
1175 lpTimeZoneInformation: PTimeZoneInformation;
1176 lpUniversalTime, lpLocalTime: PSystemTime): BOOL;
1177 var
1178 ft: TFileTime;
1179 lBias: LongInt;
1180 llTime: Int64;
1181 tzinfo: TTimeZoneInformation;
1182 begin
1183 if (lpTimeZoneInformation <> nil) then
1184 tzinfo := lpTimeZoneInformation^ else
1185 if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
1186 begin
1187 Result := False;
1188 Exit;
1189 end;
1190
1191 if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then
1192 begin
1193 Result := False;
1194 Exit;
1195 end;
1196 llTime := PInt64(@ft)^;
1197 if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then
1198 begin
1199 Result := False;
1200 Exit;
1201 end;
1202 (* convert minutes to 100-nanoseconds-ticks *)
1203 dec(llTime, Int64(lBias) * 600000000);
1204 PInt64(@ft)^ := llTime;
1205 Result := FileTimeToSystemTime(ft, lpLocalTime^);
1206 end;
1207
1208 function TzSpecificLocalTimeToSystemTime(
1209 const lpTimeZoneInformation: PTimeZoneInformation;
1210 const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL;
1211 var
1212 ft: TFileTime;
1213 lBias: LongInt;
1214 t: Int64;
1215 tzinfo: TTimeZoneInformation;
1216 begin
1217 if (lpTimeZoneInformation <> nil) then
1218 tzinfo := lpTimeZoneInformation^
1219 else
1220 if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
1221 begin
1222 Result := False;
1223 Exit;
1224 end;
1225
1226 if (not SystemTimeToFileTime(lpLocalTime^, ft)) then
1227 begin
1228 Result := False;
1229 Exit;
1230 end;
1231 t := PInt64(@ft)^;
1232 if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then
1233 begin
1234 Result := False;
1235 Exit;
1236 end;
1237 (* convert minutes to 100-nanoseconds-ticks *)
1238 inc(t, Int64(lBias) * 600000000);
1239 PInt64(@ft)^ := t;
1240 Result := FileTimeToSystemTime(ft, lpUniversalTime^);
1241 end;
1242 {$ELSE}
1243 function TzSpecificLocalTimeToSystemTime(
1244 lpTimeZoneInformation: PTimeZoneInformation;
1245 lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
1246
1247 function SystemTimeToTzSpecificLocalTime(
1248 lpTimeZoneInformation: PTimeZoneInformation;
1249 lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
1250 {$ENDIF}
1251
1252 function JavaToDelphiDateTime(const dt: int64): TDateTime;
1253 var
1254 t: TSystemTime;
1255 begin
1256 DateTimeToSystemTime(25569 + (dt / 86400000), t);
1257 SystemTimeToTzSpecificLocalTime(nil, @t, @t);
1258 Result := SystemTimeToDateTime(t);
1259 end;
1260
1261 function DelphiToJavaDateTime(const dt: TDateTime): int64;
1262 var
1263 t: TSystemTime;
1264 begin
1265 DateTimeToSystemTime(dt, t);
1266 TzSpecificLocalTimeToSystemTime(nil, @t, @t);
1267 Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000)
1268 end;
1269 {$ENDIF}
1270
1271
1272 function SO(const s: SOString): ISuperObject; overload;
1273 begin
1274 Result := TSuperObject.ParseString(PSOChar(s), False);
1275 end;
1276
1277 function SA(const Args: array of const): ISuperObject; overload;
1278 type
1279 TByteArray = array[0..sizeof(integer) - 1] of byte;
1280 PByteArray = ^TByteArray;
1281 var
1282 j: Integer;
1283 intf: IInterface;
1284 begin
1285 Result := TSuperObject.Create(stArray);
1286 for j := 0 to length(Args) - 1 do
1287 with Result.AsArray do
1288 case TVarRec(Args[j]).VType of
1289 vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger));
1290 vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^));
1291 vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean));
1292 vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar)));
1293 vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar)));
1294 vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^));
1295 vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^));
1296 vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^)));
1297 vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^)));
1298 vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString))));
1299 vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString))));
1300 vtInterface:
1301 if TVarRec(Args[j]).VInterface = nil then
1302 Add(nil) else
1303 if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then
1304 Add(ISuperObject(intf)) else
1305 Add(nil);
1306 vtPointer :
1307 if TVarRec(Args[j]).VPointer = nil then
1308 Add(nil) else
1309 Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
1310 vtVariant:
1311 Add(SO(TVarRec(Args[j]).VVariant^));
1312 vtObject:
1313 if TVarRec(Args[j]).VPointer = nil then
1314 Add(nil) else
1315 Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
1316 vtClass:
1317 if TVarRec(Args[j]).VPointer = nil then
1318 Add(nil) else
1319 Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
1320 {$if declared(vtUnicodeString)}
1321 vtUnicodeString:
1322 Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString))));
1323 {$ifend}
1324 else
1325 assert(false);
1326 end;
1327 end;
1328
1329 function SO(const Args: array of const): ISuperObject; overload;
1330 var
1331 j: Integer;
1332 arr: ISuperObject;
1333 begin
1334 Result := TSuperObject.Create(stObject);
1335 arr := SA(Args);
1336 with arr.AsArray do
1337 for j := 0 to (Length div 2) - 1 do
1338 Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]);
1339 end;
1340
1341 function SO(const value: Variant): ISuperObject; overload;
1342 begin
1343 with TVarData(value) do
1344 case VType of
1345 varNull: Result := nil;
1346 varEmpty: Result := nil;
1347 varSmallInt: Result := TSuperObject.Create(VSmallInt);
1348 varInteger: Result := TSuperObject.Create(VInteger);
1349 varSingle: Result := TSuperObject.Create(VSingle);
1350 varDouble: Result := TSuperObject.Create(VDouble);
1351 varCurrency: Result := TSuperObject.CreateCurrency(VCurrency);
1352 varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate));
1353 varOleStr: Result := TSuperObject.Create(SOString(VOleStr));
1354 varBoolean: Result := TSuperObject.Create(VBoolean);
1355 varShortInt: Result := TSuperObject.Create(VShortInt);
1356 varByte: Result := TSuperObject.Create(VByte);
1357 varWord: Result := TSuperObject.Create(VWord);
1358 varLongWord: Result := TSuperObject.Create(VLongWord);
1359 varInt64: Result := TSuperObject.Create(VInt64);
1360 varString: Result := TSuperObject.Create(SOString(AnsiString(VString)));
1361 {$if declared(varUString)}
1362 varUString: Result := TSuperObject.Create(SOString(string(VUString)));
1363 {$ifend}
1364 else
1365 raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]);
1366 end;
1367 end;
1368
1369 function ObjectIsError(obj: TSuperObject): boolean;
1370 begin
1371 Result := PtrUInt(obj) > PtrUInt(-4000);
1372 end;
1373
1374 function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
1375 begin
1376 if obj <> nil then
1377 Result := typ = obj.DataType else
1378 Result := typ = stNull;
1379 end;
1380
1381 function ObjectGetType(const obj: ISuperObject): TSuperType;
1382 begin
1383 if obj <> nil then
1384 Result := obj.DataType else
1385 Result := stNull;
1386 end;
1387
1388 function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
1389 var
1390 i: TSuperAvlEntry;
1391 begin
1392 if ObjectIsType(obj, stObject) then
1393 begin
1394 F.Ite := TSuperAvlIterator.Create(obj.AsObject);
1395 F.Ite.First;
1396 i := F.Ite.GetIter;
1397 if i <> nil then
1398 begin
1399 f.key := i.Name;
1400 f.val := i.Value;
1401 Result := true;
1402 end else
1403 Result := False;
1404 end else
1405 Result := False;
1406 end;
1407
1408 function ObjectFindNext(var F: TSuperObjectIter): boolean;
1409 var
1410 i: TSuperAvlEntry;
1411 begin
1412 F.Ite.Next;
1413 i := F.Ite.GetIter;
1414 if i <> nil then
1415 begin
1416 f.key := i.FName;
1417 f.val := i.Value;
1418 Result := true;
1419 end else
1420 Result := False;
1421 end;
1422
1423 procedure ObjectFindClose(var F: TSuperObjectIter);
1424 begin
1425 F.Ite.Free;
1426 F.val := nil;
1427 end;
1428
1429 {$IFDEF VER210}
1430
1431 function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
1432 begin
1433 Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0);
1434 end;
1435
1436 function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
1437 begin
1438 Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble));
1439 end;
1440
1441 function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
1442 var
1443 g: TGUID;
1444 begin
1445 value.ExtractRawData(@g);
1446 Result := TSuperObject.Create(
1447 format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x',
1448 [g.D1, g.D2, g.D3,
1449 g.D4[0], g.D4[1], g.D4[2],
1450 g.D4[3], g.D4[4], g.D4[5],
1451 g.D4[6], g.D4[7]])
1452 );
1453 end;
1454
1455 function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
1456 var
1457 o: ISuperObject;
1458 begin
1459 case ObjectGetType(obj) of
1460 stBoolean:
1461 begin
1462 TValueData(Value).FAsSLong := obj.AsInteger;
1463 Result := True;
1464 end;
1465 stInt:
1466 begin
1467 TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0);
1468 Result := True;
1469 end;
1470 stString:
1471 begin
1472 o := SO(obj.AsString);
1473 if not ObjectIsType(o, stString) then
1474 Result := serialfromboolean(ctx, SO(obj.AsString), Value) else
1475 Result := False;
1476 end;
1477 else
1478 Result := False;
1479 end;
1480 end;
1481
1482 function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
1483 var
1484 dt: TDateTime;
1485 begin
1486 case ObjectGetType(obj) of
1487 stInt:
1488 begin
1489 TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger);
1490 Result := True;
1491 end;
1492 stString:
1493 begin
1494 if TryStrToDateTime(obj.AsString, dt) then
1495 begin
1496 TValueData(Value).FAsDouble := dt;
1497 Result := True;
1498 end else
1499 Result := False;
1500 end;
1501 else
1502 Result := False;
1503 end;
1504 end;
1505
1506 function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean;
1507 const
1508 hex2bin: array[#0..#102] of short = (
1509 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x00 *)
1510 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x10 *)
1511 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x20 *)
1512 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, (* 0x30 *)
1513 -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x40 *)
1514 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x50 *)
1515 -1,10,11,12,13,14,15); (* 0x60 *)
1516 var
1517 i: Integer;
1518 begin
1519 if (strlen(s) <> 36) then Exit(False);
1520
1521 if ((s[8] <> '-') or (s[13] <> '-') or (s[18] <> '-') or (s[23] <> '-')) then
1522 Exit(False);
1523
1524 for i := 0 to 35 do
1525 begin
1526 if not i in [8,13,18,23] then
1527 if ((s[i] > 'f') or ((hex2bin[s[i]] = -1) and (s[i] <> ''))) then
1528 Exit(False);
1529 end;
1530
1531 uuid.D1 := ((hex2bin[s[0]] shl 28) or (hex2bin[s[1]] shl 24) or (hex2bin[s[2]] shl 20) or (hex2bin[s[3]] shl 16) or
1532 (hex2bin[s[4]] shl 12) or (hex2bin[s[5]] shl 8) or (hex2bin[s[6]] shl 4) or hex2bin[s[7]]);
1533 uuid.D2 := (hex2bin[s[9]] shl 12) or (hex2bin[s[10]] shl 8) or (hex2bin[s[11]] shl 4) or hex2bin[s[12]];
1534 uuid.D3 := (hex2bin[s[14]] shl 12) or (hex2bin[s[15]] shl 8) or (hex2bin[s[16]] shl 4) or hex2bin[s[17]];
1535
1536 uuid.D4[0] := (hex2bin[s[19]] shl 4) or hex2bin[s[20]];
1537 uuid.D4[1] := (hex2bin[s[21]] shl 4) or hex2bin[s[22]];
1538 uuid.D4[2] := (hex2bin[s[24]] shl 4) or hex2bin[s[25]];
1539 uuid.D4[3] := (hex2bin[s[26]] shl 4) or hex2bin[s[27]];
1540 uuid.D4[4] := (hex2bin[s[28]] shl 4) or hex2bin[s[29]];
1541 uuid.D4[5] := (hex2bin[s[30]] shl 4) or hex2bin[s[31]];
1542 uuid.D4[6] := (hex2bin[s[32]] shl 4) or hex2bin[s[33]];
1543 uuid.D4[7] := (hex2bin[s[34]] shl 4) or hex2bin[s[35]];
1544 Result := True;
1545 end;
1546
1547 function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
1548 begin
1549 case ObjectGetType(obj) of
1550 stNull:
1551 begin
1552 FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0);
1553 Result := True;
1554 end;
1555 stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData);
1556 else
1557 Result := False;
1558 end;
1559 end;
1560
1561 function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload;
1562 var
1563 owned: Boolean;
1564 begin
1565 if ctx = nil then
1566 begin
1567 ctx := TSuperRttiContext.Create;
1568 owned := True;
1569 end else
1570 owned := False;
1571 try
1572 if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then
1573 raise Exception.Create('Invalid method call');
1574 finally
1575 if owned then
1576 ctx.Free;
1577 end;
1578 end;
1579
1580 function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload;
1581 begin
1582 Result := SOInvoke(obj, method, so(params), ctx)
1583 end;
1584
1585 function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue;
1586 const method: string; const params: ISuperObject;
1587 var Return: ISuperObject): TSuperInvokeResult;
1588 var
1589 t: TRttiInstanceType;
1590 m: TRttiMethod;
1591 a: TArray<TValue>;
1592 ps: TArray<TRttiParameter>;
1593 v: TValue;
1594 index: ISuperObject;
1595
1596 function GetParams: Boolean;
1597 var
1598 i: Integer;
1599 begin
1600 case ObjectGetType(params) of
1601 stArray:
1602 for i := 0 to Length(ps) - 1 do
1603 if (pfOut in ps[i].Flags) then
1604 TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
1605 if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then
1606 Exit(False);
1607 stObject:
1608 for i := 0 to Length(ps) - 1 do
1609 if (pfOut in ps[i].Flags) then
1610 TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
1611 if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then
1612 Exit(False);
1613 stNull: ;
1614 else
1615 Exit(False);
1616 end;
1617 Result := True;
1618 end;
1619
1620 procedure SetParams;
1621 var
1622 i: Integer;
1623 begin
1624 case ObjectGetType(params) of
1625 stArray:
1626 for i := 0 to Length(ps) - 1 do
1627 if (ps[i].Flags * [pfVar, pfOut]) <> [] then
1628 params.AsArray[i] := ctx.ToJson(a[i], index);
1629 stObject:
1630 for i := 0 to Length(ps) - 1 do
1631 if (ps[i].Flags * [pfVar, pfOut]) <> [] then
1632 params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index);
1633 end;
1634 end;
1635
1636 begin
1637 Result := irSuccess;
1638 index := SO;
1639 case obj.Kind of
1640 tkClass:
1641 begin
1642 t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType));
1643 m := t.GetMethod(method);
1644 if m = nil then Exit(irMethothodError);
1645 ps := m.GetParameters;
1646 SetLength(a, Length(ps));
1647 if not GetParams then Exit(irParamError);
1648 if m.IsClassMethod then
1649 begin
1650 v := m.Invoke(obj.AsObject.ClassType, a);
1651 Return := ctx.ToJson(v, index);
1652 SetParams;
1653 end else
1654 begin
1655 v := m.Invoke(obj, a);
1656 Return := ctx.ToJson(v, index);
1657 SetParams;
1658 end;
1659 end;
1660 tkClassRef:
1661 begin
1662 t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass));
1663 m := t.GetMethod(method);
1664 if m = nil then Exit(irMethothodError);
1665 ps := m.GetParameters;
1666 SetLength(a, Length(ps));
1667
1668 if not GetParams then Exit(irParamError);
1669 if m.IsClassMethod then
1670 begin
1671 v := m.Invoke(obj, a);
1672 Return := ctx.ToJson(v, index);
1673 SetParams;
1674 end else
1675 Exit(irError);
1676 end;
1677 else
1678 Exit(irError);
1679 end;
1680 end;
1681
1682 {$ENDIF}
1683
1684 { TSuperEnumerator }
1685
1686 constructor TSuperEnumerator.Create(const obj: ISuperObject);
1687 begin
1688 FObj := obj;
1689 FCount := -1;
1690 if ObjectIsType(FObj, stObject) then
1691 FObjEnum := FObj.AsObject.GetEnumerator else
1692 FObjEnum := nil;
1693 end;
1694
1695 destructor TSuperEnumerator.Destroy;
1696 begin
1697 if FObjEnum <> nil then
1698 FObjEnum.Free;
1699 end;
1700
1701 function TSuperEnumerator.MoveNext: Boolean;
1702 begin
1703 case ObjectGetType(FObj) of
1704 stObject: Result := FObjEnum.MoveNext;
1705 stArray:
1706 begin
1707 inc(FCount);
1708 if FCount < FObj.AsArray.Length then
1709 Result := True else
1710 Result := False;
1711 end;
1712 else
1713 Result := false;
1714 end;
1715 end;
1716
1717 function TSuperEnumerator.GetCurrent: ISuperObject;
1718 begin
1719 case ObjectGetType(FObj) of
1720 stObject: Result := FObjEnum.Current.Value;
1721 stArray: Result := FObj.AsArray.GetO(FCount);
1722 else
1723 Result := FObj;
1724 end;
1725 end;
1726
1727 { TSuperObject }
1728
1729 constructor TSuperObject.Create(jt: TSuperType);
1730 begin
1731 inherited Create;
1732 {$IFDEF DEBUG}
1733 InterlockedIncrement(debugcount);
1734 {$ENDIF}
1735
1736 FProcessing := false;
1737 FDataPtr := nil;
1738 FDataType := jt;
1739 case FDataType of
1740 stObject: FO.c_object := TSuperTableString.Create;
1741 stArray: FO.c_array := TSuperArray.Create;
1742 stString: FOString := '';
1743 else
1744 FO.c_object := nil;
1745 end;
1746 end;
1747
1748 constructor TSuperObject.Create(b: boolean);
1749 begin
1750 Create(stBoolean);
1751 FO.c_boolean := b;
1752 end;
1753
1754 constructor TSuperObject.Create(i: SuperInt);
1755 begin
1756 Create(stInt);
1757 FO.c_int := i;
1758 end;
1759
1760 constructor TSuperObject.Create(d: double);
1761 begin
1762 Create(stDouble);
1763 FO.c_double := d;
1764 end;
1765
1766 constructor TSuperObject.CreateCurrency(c: Currency);
1767 begin
1768 Create(stCurrency);
1769 FO.c_currency := c;
1770 end;
1771
1772 destructor TSuperObject.Destroy;
1773 begin
1774 {$IFDEF DEBUG}
1775 InterlockedDecrement(debugcount);
1776 {$ENDIF}
1777 case FDataType of
1778 stObject: FO.c_object.Free;
1779 stArray: FO.c_array.Free;
1780 end;
1781 inherited;
1782 end;
1783
1784 function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
1785 function DoEscape(str: PSOChar; len: Integer): Integer;
1786 var
1787 pos, start_offset: Integer;
1788 c: SOChar;
1789 buf: array[0..5] of SOChar;
1790 type
1791 TByteChar = record
1792 case integer of
1793 0: (a, b: Byte);
1794 1: (c: WideChar);
1795 end;
1796 begin
1797 if str = nil then
1798 begin
1799 Result := 0;
1800 exit;
1801 end;
1802 pos := 0; start_offset := 0;
1803 with writer do
1804 while pos < len do
1805 begin
1806 c := str[pos];
1807 case c of
1808 #8,#9,#10,#12,#13,'"','\','/':
1809 begin
1810 if(pos - start_offset > 0) then
1811 Append(str + start_offset, pos - start_offset);
1812
1813 if(c = #8) then Append(ESC_BS, 2)
1814 else if (c = #9) then Append(ESC_TAB, 2)
1815 else if (c = #10) then Append(ESC_LF, 2)
1816 else if (c = #12) then Append(ESC_FF, 2)
1817 else if (c = #13) then Append(ESC_CR, 2)
1818 else if (c = '"') then Append(ESC_QUOT, 2)
1819 else if (c = '\') then Append(ESC_SL, 2)
1820 else if (c = '/') then Append(ESC_SR, 2);
1821 inc(pos);
1822 start_offset := pos;
1823 end;
1824 else
1825 if (SOIChar(c) > 255) then
1826 begin
1827 if(pos - start_offset > 0) then
1828 Append(str + start_offset, pos - start_offset);
1829 buf[0] := '\';
1830 buf[1] := 'u';
1831 buf[2] := super_hex_chars[TByteChar(c).b shr 4];
1832 buf[3] := super_hex_chars[TByteChar(c).b and $f];
1833 buf[4] := super_hex_chars[TByteChar(c).a shr 4];
1834 buf[5] := super_hex_chars[TByteChar(c).a and $f];
1835 Append(@buf, 6);
1836 inc(pos);
1837 start_offset := pos;
1838 end else
1839 if (c < #32) or (c > #127) then
1840 begin
1841 if(pos - start_offset > 0) then
1842 Append(str + start_offset, pos - start_offset);
1843 buf[0] := '\';
1844 buf[1] := 'u';
1845 buf[2] := '0';
1846 buf[3] := '0';
1847 buf[4] := super_hex_chars[ord(c) shr 4];
1848 buf[5] := super_hex_chars[ord(c) and $f];
1849 Append(buf, 6);
1850 inc(pos);
1851 start_offset := pos;
1852 end else
1853 inc(pos);
1854 end;
1855 end;
1856 if(pos - start_offset > 0) then
1857 writer.Append(str + start_offset, pos - start_offset);
1858 Result := 0;
1859 end;
1860
1861 function DoMinimalEscape(str: PSOChar; len: Integer): Integer;
1862 var
1863 pos, start_offset: Integer;
1864 c: SOChar;
1865 type
1866 TByteChar = record
1867 case integer of
1868 0: (a, b: Byte);
1869 1: (c: WideChar);
1870 end;
1871 begin
1872 if str = nil then
1873 begin
1874 Result := 0;
1875 exit;
1876 end;
1877 pos := 0; start_offset := 0;
1878 with writer do
1879 while pos < len do
1880 begin
1881 c := str[pos];
1882 case c of
1883 #0:
1884 begin
1885 if(pos - start_offset > 0) then
1886 Append(str + start_offset, pos - start_offset);
1887 Append(ESC_ZERO, 6);
1888 inc(pos);
1889 start_offset := pos;
1890 end;
1891 '"':
1892 begin
1893 if(pos - start_offset > 0) then
1894 Append(str + start_offset, pos - start_offset);
1895 Append(ESC_QUOT, 2);
1896 inc(pos);
1897 start_offset := pos;
1898 end;
1899 '\':
1900 begin
1901 if(pos - start_offset > 0) then
1902 Append(str + start_offset, pos - start_offset);
1903 Append(ESC_SL, 2);
1904 inc(pos);
1905 start_offset := pos;
1906 end;
1907 '/':
1908 begin
1909 if(pos - start_offset > 0) then
1910 Append(str + start_offset, pos - start_offset);
1911 Append(ESC_SR, 2);
1912 inc(pos);
1913 start_offset := pos;
1914 end;
1915 else
1916 inc(pos);
1917 end;
1918 end;
1919 if(pos - start_offset > 0) then
1920 writer.Append(str + start_offset, pos - start_offset);
1921 Result := 0;
1922 end;
1923
1924
1925 procedure _indent(i: shortint; r: boolean);
1926 begin
1927 inc(level, i);
1928 if r then
1929 with writer do
1930 begin
1931 {$IFDEF MSWINDOWS}
1932 Append(TOK_CRLF, 2);
1933 {$ELSE}
1934 Append(TOK_LF, 1);
1935 {$ENDIF}
1936 for i := 0 to level - 1 do
1937 Append(TOK_SP, 1);
1938 end;
1939 end;
1940 var
1941 k,j: Integer;
1942 iter: TSuperObjectIter;
1943 st: AnsiString;
1944 val: ISuperObject;
1945 fbuffer: array[0..31] of AnsiChar;
1946 const
1947 ENDSTR_A: PSOChar = '": ';
1948 ENDSTR_B: PSOChar = '":';
1949 begin
1950
1951 if FProcessing then
1952 begin
1953 Result := writer.Append(TOK_NULL, 4);
1954 Exit;
1955 end;
1956
1957 FProcessing := true;
1958 with writer do
1959 try
1960 case FDataType of
1961 stObject:
1962 if FO.c_object.FCount > 0 then
1963 begin
1964 k := 0;
1965 Append(TOK_CBL, 1);
1966 if indent then _indent(1, false);
1967 if ObjectFindFirst(Self, iter) then
1968 repeat
1969 {$IFDEF SUPER_METHOD}
1970 if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then
1971 begin
1972 {$ENDIF}
1973 if (iter.val = nil) or (not iter.val.Processing) then
1974 begin
1975 if(k <> 0) then
1976 Append(TOK_COM, 1);
1977 if indent then _indent(0, true);
1978 Append(TOK_DQT, 1);
1979 if escape then
1980 doEscape(PSOChar(iter.key), Length(iter.key)) else
1981 DoMinimalEscape(PSOChar(iter.key), Length(iter.key));
1982 if indent then
1983 Append(ENDSTR_A, 3) else
1984 Append(ENDSTR_B, 2);
1985 if(iter.val = nil) then
1986 Append(TOK_NULL, 4) else
1987 iter.val.write(writer, indent, escape, level);
1988 inc(k);
1989 end;
1990 {$IFDEF SUPER_METHOD}
1991 end;
1992 {$ENDIF}
1993 until not ObjectFindNext(iter);
1994 ObjectFindClose(iter);
1995 if indent then _indent(-1, true);
1996 Result := Append(TOK_CBR, 1);
1997 end else
1998 Result := Append(TOK_OBJ, 2);
1999 stBoolean:
2000 begin
2001 if (FO.c_boolean) then
2002 Result := Append(TOK_TRUE, 4) else
2003 Result := Append(TOK_FALSE, 5);
2004 end;
2005 stInt:
2006 begin
2007 str(FO.c_int, st);
2008 Result := Append(PSOChar(SOString(st)));
2009 end;
2010 stDouble:
2011 Result := Append(PSOChar(SOString(gcvt(FO.c_double, 15, fbuffer))));
2012 stCurrency:
2013 begin
2014 Result := Append(PSOChar(CurrToStr(FO.c_currency)));
2015 end;
2016 stString:
2017 begin
2018 Append(TOK_DQT, 1);
2019 if escape then
2020 doEscape(PSOChar(FOString), Length(FOString)) else
2021 DoMinimalEscape(PSOChar(FOString), Length(FOString));
2022 Append(TOK_DQT, 1);
2023 Result := 0;
2024 end;
2025 stArray:
2026 if FO.c_array.FLength > 0 then
2027 begin
2028 Append(TOK_ARL, 1);
2029 if indent then _indent(1, true);
2030 k := 0;
2031 j := 0;
2032 while k < FO.c_array.FLength do
2033 begin
2034
2035 val := FO.c_array.GetO(k);
2036 {$IFDEF SUPER_METHOD}
2037 if not ObjectIsType(val, stMethod) then
2038 begin
2039 {$ENDIF}
2040 if (val = nil) or (not val.Processing) then
2041 begin
2042 if (j <> 0) then
2043 Append(TOK_COM, 1);
2044 if(val = nil) then
2045 Append(TOK_NULL, 4) else
2046 val.write(writer, indent, escape, level);
2047 inc(j);
2048 end;
2049 {$IFDEF SUPER_METHOD}
2050 end;
2051 {$ENDIF}
2052 inc(k);
2053 end;
2054 if indent then _indent(-1, false);
2055 Result := Append(TOK_ARR, 1);
2056 end else
2057 Result := Append(TOK_ARRAY, 2);
2058 stNull:
2059 Result := Append(TOK_NULL, 4);
2060 else
2061 Result := 0;
2062 end;
2063 finally
2064 FProcessing := false;
2065 end;
2066 end;
2067
2068 function TSuperObject.IsType(AType: TSuperType): boolean;
2069 begin
2070 Result := AType = FDataType;
2071 end;
2072
2073 function TSuperObject.AsBoolean: boolean;
2074 begin
2075 case FDataType of
2076 stBoolean: Result := FO.c_boolean;
2077 stInt: Result := (FO.c_int <> 0);
2078 stDouble: Result := (FO.c_double <> 0);
2079 stCurrency: Result := (FO.c_currency <> 0);
2080 stString: Result := (Length(FOString) <> 0);
2081 stNull: Result := False;
2082 else
2083 Result := True;
2084 end;
2085 end;
2086
2087 function TSuperObject.AsInteger: SuperInt;
2088 var
2089 code: integer;
2090 cint: SuperInt;
2091 begin
2092 case FDataType of
2093 stInt: Result := FO.c_int;
2094 stDouble: Result := round(FO.c_double);
2095 stCurrency: Result := round(FO.c_currency);
2096 stBoolean: Result := ord(FO.c_boolean);
2097 stString:
2098 begin
2099 Val(FOString, cint, code);
2100 if code = 0 then
2101 Result := cint else
2102 Result := 0;
2103 end;
2104 else
2105 Result := 0;
2106 end;
2107 end;
2108
2109 function TSuperObject.AsDouble: Double;
2110 var
2111 code: integer;
2112 cdouble: double;
2113 begin
2114 case FDataType of
2115 stDouble: Result := FO.c_double;
2116 stCurrency: Result := FO.c_currency;
2117 stInt: Result := FO.c_int;
2118 stBoolean: Result := ord(FO.c_boolean);
2119 stString:
2120 begin
2121 Val(FOString, cdouble, code);
2122 if code = 0 then
2123 Result := cdouble else
2124 Result := 0.0;
2125 end;
2126 else
2127 Result := 0.0;
2128 end;
2129 end;
2130
2131 function TSuperObject.AsCurrency: Currency;
2132 var
2133 code: integer;
2134 cdouble: double;
2135 begin
2136 case FDataType of
2137 stDouble: Result := FO.c_double;
2138 stCurrency: Result := FO.c_currency;
2139 stInt: Result := FO.c_int;
2140 stBoolean: Result := ord(FO.c_boolean);
2141 stString:
2142 begin
2143 Val(FOString, cdouble, code);
2144 if code = 0 then
2145 Result := cdouble else
2146 Result := 0.0;
2147 end;
2148 else
2149 Result := 0.0;
2150 end;
2151 end;
2152
2153 function TSuperObject.AsString: SOString;
2154 begin
2155 if FDataType = stString then
2156 Result := FOString else
2157 Result := AsJSon(false, false);
2158 end;
2159
2160 function TSuperObject.GetEnumerator: TSuperEnumerator;
2161 begin
2162 Result := TSuperEnumerator.Create(Self);
2163 end;
2164
2165 procedure TSuperObject.AfterConstruction;
2166 begin
2167 InterlockedDecrement(FRefCount);
2168 end;
2169
2170 procedure TSuperObject.BeforeDestruction;
2171 begin
2172 if RefCount <> 0 then
2173 raise Exception.Create('Invalid pointer');
2174 end;
2175
2176 function TSuperObject.AsArray: TSuperArray;
2177 begin
2178 if FDataType = stArray then
2179 Result := FO.c_array else
2180 Result := nil;
2181 end;
2182
2183 function TSuperObject.AsObject: TSuperTableString;
2184 begin
2185 if FDataType = stObject then
2186 Result := FO.c_object else
2187 Result := nil;
2188 end;
2189
2190 function TSuperObject.AsJSon(indent, escape: boolean): SOString;
2191 var
2192 pb: TSuperWriterString;
2193 begin
2194 pb := TSuperWriterString.Create;
2195 try
2196 if(Write(pb, indent, escape, 0) < 0) then
2197 begin
2198 Result := '';
2199 Exit;
2200 end;
2201 if pb.FBPos > 0 then
2202 Result := pb.FBuf else
2203 Result := '';
2204 finally
2205 pb.Free;
2206 end;
2207 end;
2208
2209 class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject;
2210 options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
2211 var
2212 tok: TSuperTokenizer;
2213 obj: ISuperObject;
2214 begin
2215 tok := TSuperTokenizer.Create;
2216 obj := ParseEx(tok, s, -1, strict, this, options, put, dt);
2217 if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then
2218 Result := nil else
2219 Result := obj;
2220 tok.Free;
2221 end;
2222
2223 class function TSuperObject.ParseStream(stream: TStream; strict: Boolean;
2224 partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
2225 const put: ISuperObject; dt: TSuperType): ISuperObject;
2226 const
2227 BUFFER_SIZE = 1024;
2228 var
2229 tok: TSuperTokenizer;
2230 buffera: array[0..BUFFER_SIZE-1] of AnsiChar;
2231 bufferw: array[0..BUFFER_SIZE-1] of SOChar;
2232 bom: array[0..1] of byte;
2233 unicode: boolean;
2234 j, size: Integer;
2235 st: string;
2236 begin
2237 st := '';
2238 tok := TSuperTokenizer.Create;
2239
2240 if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then
2241 begin
2242 unicode := true;
2243 size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
2244 end else
2245 begin
2246 unicode := false;
2247 stream.Seek(0, soFromBeginning);
2248 size := stream.Read(buffera, BUFFER_SIZE);
2249 end;
2250
2251 while size > 0 do
2252 begin
2253 if not unicode then
2254 for j := 0 to size - 1 do
2255 bufferw[j] := SOChar(buffera[j]);
2256 ParseEx(tok, bufferw, size, strict, this, options, put, dt);
2257
2258 if tok.err = teContinue then
2259 begin
2260 if not unicode then
2261 size := stream.Read(buffera, BUFFER_SIZE) else
2262 size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
2263 end else
2264 Break;
2265 end;
2266 if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then
2267 Result := nil else
2268 Result := tok.stack[tok.depth].current;
2269 tok.Free;
2270 end;
2271
2272 class function TSuperObject.ParseFile(const FileName: string; strict: Boolean;
2273 partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
2274 const put: ISuperObject; dt: TSuperType): ISuperObject;
2275 var
2276 stream: TFileStream;
2277 begin
2278 stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite);
2279 try
2280 Result := ParseStream(stream, strict, partial, this, options, put, dt);
2281 finally
2282 stream.Free;
2283 end;
2284 end;
2285
2286 class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer;
2287 strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
2288
2289 const
2290 spaces = [#32,#8,#9,#10,#12,#13];
2291 delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0];
2292 reserved = delimiters + spaces;
2293 path = ['a'..'z', 'A'..'Z', '.', '_'];
2294
2295 function hexdigit(x: SOChar): byte;
2296 begin
2297 if x <= '9' then
2298 Result := byte(x) - byte('0') else
2299 Result := (byte(x) and 7) + 9;
2300 end;
2301 function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end;
2302
2303 var
2304 obj: ISuperObject;
2305 v: SOChar;
2306 {$IFDEF SUPER_METHOD}
2307 sm: TSuperMethod;
2308 {$ENDIF}
2309 numi: SuperInt;
2310 numd: Double;
2311 code: integer;
2312 TokRec: PSuperTokenerSrec;
2313 evalstack: integer;
2314 p: PSOChar;
2315
2316 function IsEndDelimiter(v: AnsiChar): Boolean;
2317 begin
2318 if tok.depth > 0 then
2319 case tok.stack[tok.depth - 1].state of
2320 tsArrayAdd: Result := v in [',', ']', #0];
2321 tsObjectValueAdd: Result := v in [',', '}', #0];
2322 else
2323 Result := v = #0;
2324 end else
2325 Result := v = #0;
2326 end;
2327
2328 label out, redo_char;
2329 begin
2330 evalstack := 0;
2331 obj := nil;
2332 Result := nil;
2333 TokRec := @tok.stack[tok.depth];
2334
2335 tok.char_offset := 0;
2336 tok.err := teSuccess;
2337
2338 repeat
2339 if (tok.char_offset = len) then
2340 begin
2341 if (tok.depth = 0) and (TokRec^.state = tsEatws) and
2342 (TokRec^.saved_state = tsFinish) then
2343 tok.err := teSuccess else
2344 tok.err := teContinue;
2345 goto out;
2346 end;
2347
2348 v := str^;
2349
2350 case v of
2351 #10:
2352 begin
2353 inc(tok.line);
2354 tok.col := 0;
2355 end;
2356 #9: inc(tok.col, 4);
2357 else
2358 inc(tok.col);
2359 end;
2360
2361 redo_char:
2362 case TokRec^.state of
2363 tsEatws:
2364 begin
2365 if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else
2366 if (v = '/') then
2367 begin
2368 tok.pb.Reset;
2369 tok.pb.Append(@v, 1);
2370 TokRec^.state := tsCommentStart;
2371 end else begin
2372 TokRec^.state := TokRec^.saved_state;
2373 goto redo_char;
2374 end
2375 end;
2376
2377 tsStart:
2378 case v of
2379 '"',
2380 '''':
2381 begin
2382 TokRec^.state := tsString;
2383 tok.pb.Reset;
2384 tok.quote_char := v;
2385 end;
2386 '-':
2387 begin
2388 TokRec^.state := tsNumber;
2389 tok.pb.Reset;
2390 tok.is_double := 0;
2391 tok.floatcount := -1;
2392 goto redo_char;
2393 end;
2394
2395 '0'..'9':
2396 begin
2397 if (tok.depth = 0) then
2398 case ObjectGetType(this) of
2399 stObject:
2400 begin
2401 TokRec^.state := tsIdentifier;
2402 TokRec^.current := this;
2403 goto redo_char;
2404 end;
2405 end;
2406 TokRec^.state := tsNumber;
2407 tok.pb.Reset;
2408 tok.is_double := 0;
2409 tok.floatcount := -1;
2410 goto redo_char;
2411 end;
2412 '{':
2413 begin
2414 TokRec^.state := tsEatws;
2415 TokRec^.saved_state := tsObjectFieldStart;
2416 TokRec^.current := TSuperObject.Create(stObject);
2417 end;
2418 '[':
2419 begin
2420 TokRec^.state := tsEatws;
2421 TokRec^.saved_state := tsArray;
2422 TokRec^.current := TSuperObject.Create(stArray);
2423 end;
2424 {$IFDEF SUPER_METHOD}
2425 '(':
2426 begin
2427 if (tok.depth = 0) and ObjectIsType(this, stMethod) then
2428 begin
2429 TokRec^.current := this;
2430 TokRec^.state := tsParamValue;
2431 end;
2432 end;
2433 {$ENDIF}
2434 'N',
2435 'n':
2436 begin
2437 TokRec^.state := tsNull;
2438 tok.pb.Reset;
2439 tok.st_pos := 0;
2440 goto redo_char;
2441 end;
2442 'T',
2443 't',
2444 'F',
2445 'f':
2446 begin
2447 TokRec^.state := tsBoolean;
2448 tok.pb.Reset;
2449 tok.st_pos := 0;
2450 goto redo_char;
2451 end;
2452 else
2453 TokRec^.state := tsIdentifier;
2454 tok.pb.Reset;
2455 goto redo_char;
2456 end;
2457
2458 tsFinish:
2459 begin
2460 if(tok.depth = 0) then goto out;
2461 obj := TokRec^.current;
2462 tok.ResetLevel(tok.depth);
2463 dec(tok.depth);
2464 TokRec := @tok.stack[tok.depth];
2465 goto redo_char;
2466 end;
2467
2468 tsNull:
2469 begin
2470 tok.pb.Append(@v, 1);
2471 if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
2472 begin
2473 if (tok.st_pos = 4) then
2474 if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
2475 TokRec^.state := tsIdentifier else
2476 begin
2477 TokRec^.current := TSuperObject.Create(stNull);
2478 TokRec^.saved_state := tsFinish;
2479 TokRec^.state := tsEatws;
2480 goto redo_char;
2481 end;
2482 end else
2483 begin
2484 TokRec^.state := tsIdentifier;
2485 tok.pb.FBuf[tok.st_pos] := #0;
2486 dec(tok.pb.FBPos);
2487 goto redo_char;
2488 end;
2489 inc(tok.st_pos);
2490 end;
2491
2492 tsCommentStart:
2493 begin
2494 if(v = '*') then
2495 begin
2496 TokRec^.state := tsComment;
2497 end else
2498 if (v = '/') then
2499 begin
2500 TokRec^.state := tsCommentEol;
2501 end else
2502 begin
2503 tok.err := teParseComment;
2504 goto out;
2505 end;
2506 tok.pb.Append(@v, 1);
2507 end;
2508
2509 tsComment:
2510 begin
2511 if(v = '*') then
2512 TokRec^.state := tsCommentEnd;
2513 tok.pb.Append(@v, 1);
2514 end;
2515
2516 tsCommentEol:
2517 begin
2518 if (v = #10) then
2519 TokRec^.state := tsEatws else
2520 tok.pb.Append(@v, 1);
2521 end;
2522
2523 tsCommentEnd:
2524 begin
2525 tok.pb.Append(@v, 1);
2526 if (v = '/') then
2527 TokRec^.state := tsEatws else
2528 TokRec^.state := tsComment;
2529 end;
2530
2531 tsString:
2532 begin
2533 if (v = tok.quote_char) then
2534 begin
2535 TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString));
2536 TokRec^.saved_state := tsFinish;
2537 TokRec^.state := tsEatws;
2538 end else
2539 if (v = '\') then
2540 begin
2541 TokRec^.saved_state := tsString;
2542 TokRec^.state := tsStringEscape;
2543 end else
2544 begin
2545 tok.pb.Append(@v, 1);
2546 end
2547 end;
2548
2549 tsEvalProperty:
2550 begin
2551 if (TokRec^.current = nil) and (foCreatePath in options) then
2552 begin
2553 TokRec^.current := TSuperObject.Create(stObject);
2554 TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
2555 end else
2556 if not ObjectIsType(TokRec^.current, stObject) then
2557 begin
2558 tok.err := teEvalObject;
2559 goto out;
2560 end;
2561 tok.pb.Reset;
2562 TokRec^.state := tsIdentifier;
2563 goto redo_char;
2564 end;
2565
2566 tsEvalArray:
2567 begin
2568 if (TokRec^.current = nil) and (foCreatePath in options) then
2569 begin
2570 TokRec^.current := TSuperObject.Create(stArray);
2571 TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
2572 end else
2573 if not ObjectIsType(TokRec^.current, stArray) then
2574 begin
2575 tok.err := teEvalArray;
2576 goto out;
2577 end;
2578 tok.pb.Reset;
2579 TokRec^.state := tsParamValue;
2580 goto redo_char;
2581 end;
2582 {$IFDEF SUPER_METHOD}
2583 tsEvalMethod:
2584 begin
2585 if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
2586 begin
2587 tok.pb.Reset;
2588 TokRec^.obj := TSuperObject.Create(stArray);
2589 TokRec^.state := tsMethodValue;
2590 goto redo_char;
2591 end else
2592 begin
2593 tok.err := teEvalMethod;
2594 goto out;
2595 end;
2596 end;
2597
2598 tsMethodValue:
2599 begin
2600 case v of
2601 ')':
2602 TokRec^.state := tsIdentifier;
2603 else
2604 if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
2605 begin
2606 tok.err := teDepth;
2607 goto out;
2608 end;
2609 inc(evalstack);
2610 TokRec^.state := tsMethodPut;
2611 inc(tok.depth);
2612 tok.ResetLevel(tok.depth);
2613 TokRec := @tok.stack[tok.depth];
2614 goto redo_char;
2615 end;
2616 end;
2617
2618 tsMethodPut:
2619 begin
2620 TokRec^.obj.AsArray.Add(obj);
2621 case v of
2622 ',':
2623 begin
2624 tok.pb.Reset;
2625 TokRec^.saved_state := tsMethodValue;
2626 TokRec^.state := tsEatws;
2627 end;
2628 ')':
2629 begin
2630 if TokRec^.obj.AsArray.Length = 1 then
2631 TokRec^.obj := TokRec^.obj.AsArray.GetO(0);
2632 dec(evalstack);
2633 tok.pb.Reset;
2634 TokRec^.saved_state := tsIdentifier;
2635 TokRec^.state := tsEatws;
2636 end;
2637 else
2638 tok.err := teEvalMethod;
2639 goto out;
2640 end;
2641 end;
2642 {$ENDIF}
2643 tsParamValue:
2644 begin
2645 case v of
2646 ']':
2647 TokRec^.state := tsIdentifier;
2648 else
2649 if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
2650 begin
2651 tok.err := teDepth;
2652 goto out;
2653 end;
2654 inc(evalstack);
2655 TokRec^.state := tsParamPut;
2656 inc(tok.depth);
2657 tok.ResetLevel(tok.depth);
2658 TokRec := @tok.stack[tok.depth];
2659 goto redo_char;
2660 end;
2661 end;
2662
2663 tsParamPut:
2664 begin
2665 dec(evalstack);
2666 TokRec^.obj := obj;
2667 tok.pb.Reset;
2668 TokRec^.saved_state := tsIdentifier;
2669 TokRec^.state := tsEatws;
2670 if v <> ']' then
2671 begin
2672 tok.err := teEvalArray;
2673 goto out;
2674 end;
2675 end;
2676
2677 tsIdentifier:
2678 begin
2679 if (this = nil) then
2680 begin
2681 if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then
2682 begin
2683 if not strict then
2684 begin
2685 tok.pb.TrimRight;
2686 TokRec^.current := TSuperObject.Create(tok.pb.Fbuf);
2687 TokRec^.saved_state := tsFinish;
2688 TokRec^.state := tsEatws;
2689 goto redo_char;
2690 end else
2691 begin
2692 tok.err := teParseString;
2693 goto out;
2694 end;
2695 end else
2696 if (v = '\') then
2697 begin
2698 TokRec^.saved_state := tsIdentifier;
2699 TokRec^.state := tsStringEscape;
2700 end else
2701 tok.pb.Append(@v, 1);
2702 end else
2703 begin
2704 if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then
2705 begin
2706 TokRec^.gparent := TokRec^.parent;
2707 if TokRec^.current = nil then
2708 TokRec^.parent := this else
2709 TokRec^.parent := TokRec^.current;
2710
2711 case ObjectGetType(TokRec^.parent) of
2712 stObject:
2713 case v of
2714 '.':
2715 begin
2716 TokRec^.state := tsEvalProperty;
2717 if tok.pb.FBPos > 0 then
2718 TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
2719 end;
2720 '[':
2721 begin
2722 TokRec^.state := tsEvalArray;
2723 if tok.pb.FBPos > 0 then
2724 TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
2725 end;
2726 '(':
2727 begin
2728 TokRec^.state := tsEvalMethod;
2729 if tok.pb.FBPos > 0 then
2730 TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
2731 end;
2732 else
2733 if tok.pb.FBPos > 0 then
2734 TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
2735 if (foPutValue in options) and (evalstack = 0) then
2736 begin
2737 TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put);
2738 TokRec^.current := put
2739 end else
2740 if (foDelete in options) and (evalstack = 0) then
2741 begin
2742 TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf);
2743 end else
2744 if (TokRec^.current = nil) and (foCreatePath in options) then
2745 begin
2746 TokRec^.current := TSuperObject.Create(dt);
2747 TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current);
2748 end;
2749 TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
2750 TokRec^.state := tsFinish;
2751 goto redo_char;
2752 end;
2753 stArray:
2754 begin
2755 if TokRec^.obj <> nil then
2756 begin
2757 if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then
2758 begin
2759 tok.err := teEvalInt;
2760 TokRec^.obj := nil;
2761 goto out;
2762 end;
2763 numi := TokRec^.obj.AsInteger;
2764 TokRec^.obj := nil;
2765
2766 TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
2767 case v of
2768 '.':
2769 if (TokRec^.current = nil) and (foCreatePath in options) then
2770 begin
2771 TokRec^.current := TSuperObject.Create(stObject);
2772 TokRec^.parent.AsArray.PutO(numi, TokRec^.current);
2773 end else
2774 if (TokRec^.current = nil) then
2775 begin
2776 tok.err := teEvalObject;
2777 goto out;
2778 end;
2779 '[':
2780 begin
2781 if (TokRec^.current = nil) and (foCreatePath in options) then
2782 begin
2783 TokRec^.current := TSuperObject.Create(stArray);
2784 TokRec^.parent.AsArray.Add(TokRec^.current);
2785 end else
2786 if (TokRec^.current = nil) then
2787 begin
2788 tok.err := teEvalArray;
2789 goto out;
2790 end;
2791 TokRec^.state := tsEvalArray;
2792 end;
2793 '(': TokRec^.state := tsEvalMethod;
2794 else
2795 if (foPutValue in options) and (evalstack = 0) then
2796 begin
2797 TokRec^.parent.AsArray.PutO(numi, put);
2798 TokRec^.current := put;
2799 end else
2800 if (foDelete in options) and (evalstack = 0) then
2801 begin
2802 TokRec^.current := TokRec^.parent.AsArray.Delete(numi);
2803 end else
2804 TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
2805 TokRec^.state := tsFinish;
2806 goto redo_char
2807 end;
2808 end else
2809 begin
2810 case v of
2811 '.':
2812 begin
2813 if (foPutValue in options) then
2814 begin
2815 TokRec^.current := TSuperObject.Create(stObject);
2816 TokRec^.parent.AsArray.Add(TokRec^.current);
2817 end else
2818 TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
2819 end;
2820 '[':
2821 begin
2822 if (foPutValue in options) then
2823 begin
2824 TokRec^.current := TSuperObject.Create(stArray);
2825 TokRec^.parent.AsArray.Add(TokRec^.current);
2826 end else
2827 TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
2828 TokRec^.state := tsEvalArray;
2829 end;
2830 '(':
2831 begin
2832 if not (foPutValue in options) then
2833 TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else
2834 TokRec^.current := nil;
2835
2836 TokRec^.state := tsEvalMethod;
2837 end;
2838 else
2839 if (foPutValue in options) and (evalstack = 0) then
2840 begin
2841 TokRec^.parent.AsArray.Add(put);
2842 TokRec^.current := put;
2843 end else
2844 if tok.pb.FBPos = 0 then
2845 TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
2846 TokRec^.state := tsFinish;
2847 goto redo_char
2848 end;
2849 end;
2850 end;
2851 {$IFDEF SUPER_METHOD}
2852 stMethod:
2853 case v of
2854 '.':
2855 begin
2856 TokRec^.current := nil;
2857 sm := TokRec^.parent.AsMethod;
2858 sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
2859 TokRec^.obj := nil;
2860 end;
2861 '[':
2862 begin
2863 TokRec^.current := nil;
2864 sm := TokRec^.parent.AsMethod;
2865 sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
2866 TokRec^.state := tsEvalArray;
2867 TokRec^.obj := nil;
2868 end;
2869 '(':
2870 begin
2871 TokRec^.current := nil;
2872 sm := TokRec^.parent.AsMethod;
2873 sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
2874 TokRec^.state := tsEvalMethod;
2875 TokRec^.obj := nil;
2876 end;
2877 else
2878 if not (foPutValue in options) or (evalstack > 0) then
2879 begin
2880 TokRec^.current := nil;
2881 sm := TokRec^.parent.AsMethod;
2882 sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
2883 TokRec^.obj := nil;
2884 TokRec^.state := tsFinish;
2885 goto redo_char
2886 end else
2887 begin
2888 tok.err := teEvalMethod;
2889 TokRec^.obj := nil;
2890 goto out;
2891 end;
2892 end;
2893 {$ENDIF}
2894 end;
2895 end else
2896 tok.pb.Append(@v, 1);
2897 end;
2898 end;
2899
2900 tsStringEscape:
2901 case v of
2902 'b',
2903 'n',
2904 'r',
2905 't',
2906 'f':
2907 begin
2908 if(v = 'b') then tok.pb.Append(TOK_BS, 1)
2909 else if(v = 'n') then tok.pb.Append(TOK_LF, 1)
2910 else if(v = 'r') then tok.pb.Append(TOK_CR, 1)
2911 else if(v = 't') then tok.pb.Append(TOK_TAB, 1)
2912 else if(v = 'f') then tok.pb.Append(TOK_FF, 1);
2913 TokRec^.state := TokRec^.saved_state;
2914 end;
2915 'u':
2916 begin
2917 tok.ucs_char := 0;
2918 tok.st_pos := 0;
2919 TokRec^.state := tsEscapeUnicode;
2920 end;
2921 'x':
2922 begin
2923 tok.ucs_char := 0;
2924 tok.st_pos := 0;
2925 TokRec^.state := tsEscapeHexadecimal;
2926 end
2927 else
2928 tok.pb.Append(@v, 1);
2929 TokRec^.state := TokRec^.saved_state;
2930 end;
2931
2932 tsEscapeUnicode:
2933 begin
2934 if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
2935 begin
2936 inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4)));
2937 inc(tok.st_pos);
2938 if (tok.st_pos = 4) then
2939 begin
2940 tok.pb.Append(@tok.ucs_char, 1);
2941 TokRec^.state := TokRec^.saved_state;
2942 end
2943 end else
2944 begin
2945 tok.err := teParseString;
2946 goto out;
2947 end
2948 end;
2949 tsEscapeHexadecimal:
2950 begin
2951 if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
2952 begin
2953 inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4)));
2954 inc(tok.st_pos);
2955 if (tok.st_pos = 2) then
2956 begin
2957 tok.pb.Append(@tok.ucs_char, 1);
2958 TokRec^.state := TokRec^.saved_state;
2959 end
2960 end else
2961 begin
2962 tok.err := teParseString;
2963 goto out;
2964 end
2965 end;
2966 tsBoolean:
2967 begin
2968 tok.pb.Append(@v, 1);
2969 if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
2970 begin
2971 if (tok.st_pos = 4) then
2972 if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
2973 TokRec^.state := tsIdentifier else
2974 begin
2975 TokRec^.current := TSuperObject.Create(true);
2976 TokRec^.saved_state := tsFinish;
2977 TokRec^.state := tsEatws;
2978 goto redo_char;
2979 end
2980 end else
2981 if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then
2982 begin
2983 if (tok.st_pos = 5) then
2984 if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
2985 TokRec^.state := tsIdentifier else
2986 begin
2987 TokRec^.current := TSuperObject.Create(false);
2988 TokRec^.saved_state := tsFinish;
2989 TokRec^.state := tsEatws;
2990 goto redo_char;
2991 end
2992 end else
2993 begin
2994 TokRec^.state := tsIdentifier;
2995 tok.pb.FBuf[tok.st_pos] := #0;
2996 dec(tok.pb.FBPos);
2997 goto redo_char;
2998 end;
2999 inc(tok.st_pos);
3000 end;
3001
3002 tsNumber:
3003 begin
3004 if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then
3005 begin
3006 tok.pb.Append(@v, 1);
3007 if (SOIChar(v) < 256) then
3008 case v of
3009 '.': begin
3010 tok.is_double := 1;
3011 tok.floatcount := 0;
3012 end;
3013 'e','E':
3014 begin
3015 tok.is_double := 1;
3016 tok.floatcount := -1;
3017 end;
3018 '0'..'9':
3019 begin
3020
3021 if (tok.is_double = 1) and (tok.floatcount >= 0) then
3022 begin
3023 inc(tok.floatcount);
3024 if tok.floatcount > 4 then
3025 tok.floatcount := -1;
3026 end;
3027 end;
3028 end;
3029 end else
3030 begin
3031 if (tok.is_double = 0) then
3032 begin
3033 val(tok.pb.FBuf, numi, code);
3034 if ObjectIsType(this, stArray) then
3035 begin
3036 if (foPutValue in options) and (evalstack = 0) then
3037 begin
3038 this.AsArray.PutO(numi, put);
3039 TokRec^.current := put;
3040 end else
3041 if (foDelete in options) and (evalstack = 0) then
3042 TokRec^.current := this.AsArray.Delete(numi) else
3043 TokRec^.current := this.AsArray.GetO(numi);
3044 end else
3045 TokRec^.current := TSuperObject.Create(numi);
3046
3047 end else
3048 if (tok.is_double <> 0) then
3049 begin
3050 if tok.floatcount >= 0 then
3051 begin
3052 p := tok.pb.FBuf;
3053 while p^ <> '.' do inc(p);
3054 for code := 0 to tok.floatcount - 1 do
3055 begin
3056 p^ := p[1];
3057 inc(p);
3058 end;
3059 p^ := #0;
3060 val(tok.pb.FBuf, numi, code);
3061 case tok.floatcount of
3062 0: numi := numi * 10000;
3063 1: numi := numi * 1000;
3064 2: numi := numi * 100;
3065 3: numi := numi * 10;
3066 end;
3067 TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^);
3068 end else
3069 begin
3070 val(tok.pb.FBuf, numd, code);
3071 TokRec^.current := TSuperObject.Create(numd);
3072 end;
3073 end else
3074 begin
3075 tok.err := teParseNumber;
3076 goto out;
3077 end;
3078 TokRec^.saved_state := tsFinish;
3079 TokRec^.state := tsEatws;
3080 goto redo_char;
3081 end
3082 end;
3083
3084 tsArray:
3085 begin
3086 if (v = ']') then
3087 begin
3088 TokRec^.saved_state := tsFinish;
3089 TokRec^.state := tsEatws;
3090 end else
3091 begin
3092 if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
3093 begin
3094 tok.err := teDepth;
3095 goto out;
3096 end;
3097 TokRec^.state := tsArrayAdd;
3098 inc(tok.depth);
3099 tok.ResetLevel(tok.depth);
3100 TokRec := @tok.stack[tok.depth];
3101 goto redo_char;
3102 end
3103 end;
3104
3105 tsArrayAdd:
3106 begin
3107 TokRec^.current.AsArray.Add(obj);
3108 TokRec^.saved_state := tsArraySep;
3109 TokRec^.state := tsEatws;
3110 goto redo_char;
3111 end;
3112
3113 tsArraySep:
3114 begin
3115 if (v = ']') then
3116 begin
3117 TokRec^.saved_state := tsFinish;
3118 TokRec^.state := tsEatws;
3119 end else
3120 if (v = ',') then
3121 begin
3122 TokRec^.saved_state := tsArray;
3123 TokRec^.state := tsEatws;
3124 end else
3125 begin
3126 tok.err := teParseArray;
3127 goto out;
3128 end
3129 end;
3130
3131 tsObjectFieldStart:
3132 begin
3133 if (v = '}') then
3134 begin
3135 TokRec^.saved_state := tsFinish;
3136 TokRec^.state := tsEatws;
3137 end else
3138 if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then
3139 begin
3140 tok.quote_char := v;
3141 tok.pb.Reset;
3142 TokRec^.state := tsObjectField;
3143 end else
3144 if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then
3145 begin
3146 TokRec^.state := tsObjectUnquotedField;
3147 tok.pb.Reset;
3148 goto redo_char;
3149 end else
3150 begin
3151 tok.err := teParseObjectKeyName;
3152 goto out;
3153 end
3154 end;
3155
3156 tsObjectField:
3157 begin
3158 if (v = tok.quote_char) then
3159 begin
3160 TokRec^.field_name := tok.pb.FBuf;
3161 TokRec^.saved_state := tsObjectFieldEnd;
3162 TokRec^.state := tsEatws;
3163 end else
3164 if (v = '\') then
3165 begin
3166 TokRec^.saved_state := tsObjectField;
3167 TokRec^.state := tsStringEscape;
3168 end else
3169 begin
3170 tok.pb.Append(@v, 1);
3171 end
3172 end;
3173
3174 tsObjectUnquotedField:
3175 begin
3176 if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then
3177 begin
3178 TokRec^.field_name := tok.pb.FBuf;
3179 TokRec^.saved_state := tsObjectFieldEnd;
3180 TokRec^.state := tsEatws;
3181 goto redo_char;
3182 end else
3183 if (v = '\') then
3184 begin
3185 TokRec^.saved_state := tsObjectUnquotedField;
3186 TokRec^.state := tsStringEscape;
3187 end else
3188 tok.pb.Append(@v, 1);
3189 end;
3190
3191 tsObjectFieldEnd:
3192 begin
3193 if (v = ':') then
3194 begin
3195 TokRec^.saved_state := tsObjectValue;
3196 TokRec^.state := tsEatws;
3197 end else
3198 begin
3199 tok.err := teParseObjectKeySep;
3200 goto out;
3201 end
3202 end;
3203
3204 tsObjectValue:
3205 begin
3206 if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
3207 begin
3208 tok.err := teDepth;
3209 goto out;
3210 end;
3211 TokRec^.state := tsObjectValueAdd;
3212 inc(tok.depth);
3213 tok.ResetLevel(tok.depth);
3214 TokRec := @tok.stack[tok.depth];
3215 goto redo_char;
3216 end;
3217
3218 tsObjectValueAdd:
3219 begin
3220 TokRec^.current.AsObject.PutO(TokRec^.field_name, obj);
3221 TokRec^.field_name := '';
3222 TokRec^.saved_state := tsObjectSep;
3223 TokRec^.state := tsEatws;
3224 goto redo_char;
3225 end;
3226
3227 tsObjectSep:
3228 begin
3229 if (v = '}') then
3230 begin
3231 TokRec^.saved_state := tsFinish;
3232 TokRec^.state := tsEatws;
3233 end else
3234 if (v = ',') then
3235 begin
3236 TokRec^.saved_state := tsObjectFieldStart;
3237 TokRec^.state := tsEatws;
3238 end else
3239 begin
3240 tok.err := teParseObjectValueSep;
3241 goto out;
3242 end
3243 end;
3244 end;
3245 inc(str);
3246 inc(tok.char_offset);
3247 until v = #0;
3248
3249 if(TokRec^.state <> tsFinish) and
3250 (TokRec^.saved_state <> tsFinish) then
3251 tok.err := teParseEof;
3252
3253 out:
3254 if(tok.err in [teSuccess]) then
3255 begin
3256 {$IFDEF SUPER_METHOD}
3257 if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
3258 begin
3259 sm := TokRec^.current.AsMethod;
3260 sm(TokRec^.parent, put, Result);
3261 end else
3262 {$ENDIF}
3263 Result := TokRec^.current;
3264 end else
3265 Result := nil;
3266 end;
3267
3268 procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject);
3269 begin
3270 ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value);
3271 end;
3272
3273 procedure TSuperObject.PutB(const path: SOString; Value: Boolean);
3274 begin
3275 ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
3276 end;
3277
3278 procedure TSuperObject.PutD(const path: SOString; Value: Double);
3279 begin
3280 ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
3281 end;
3282
3283 procedure TSuperObject.PutC(const path: SOString; Value: Currency);
3284 begin
3285 ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value));
3286 end;
3287
3288 procedure TSuperObject.PutI(const path: SOString; Value: SuperInt);
3289 begin
3290 ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
3291 end;
3292
3293 procedure TSuperObject.PutS(const path: SOString; const Value: SOString);
3294 begin
3295 ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
3296 end;
3297
3298 function TSuperObject.QueryInterface(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<PTypeInfo, TSerialFromJson>.Create;
5850 SerialToJson := TDictionary<PTypeInfo, TSerialToJson>.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<T>(const obj: ISuperObject): T;
5889 var
5890 ret: TValue;
5891 begin
5892 if FromJson(TypeInfo(T), obj, ret) then
5893 Result := ret.AsType<T> else
5894 raise exception.Create('Marshalling error');
5895 end;
5896
5897 function TSuperRttiContext.AsJson<T>(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<AnsiChar>));
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<WideChar>));
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