diff --git a/bin/test.json b/bin/test.json
new file mode 100644
index 0000000..6c44514
--- /dev/null
+++ b/bin/test.json
@@ -0,0 +1 @@
+{"status":"Success","returnType":19,"origin":{"cityName":"南京市","listType":0,"results":[{"name":"南京师范大学(随园校区)","address":"宁海路122号南京师范大学随园校区(近五台山体育馆北门)","telephone":"(025)83598010","location":{"lng":118.76910802631,"lat":32.053549002457}},{"name":"南京师范大学紫金校区","address":"南京市玄武区板仓街78号","telephone":"(025)85481074","location":{"lng":118.82148937875,"lat":32.071797107485}},{"name":"南京师范大学(商学院)","address":"杨家坟","telephone":"","location":{"lng":118.74468339485,"lat":31.924527172637}},{"name":"南京师范大学医院","address":"南京市鼓楼区","telephone":"","location":{"lng":118.76635014944,"lat":32.053867502814}},{"name":"南京师大自学考试办公室","address":"宁海路122","telephone":"","location":{"lng":118.76877004777,"lat":32.054465459609}},{"name":"南京师大劳动服务公司","address":"板仓街78号","telephone":"","location":{"lng":118.82260967369,"lat":32.071724518845}},{"name":"南京师大教师培训中心","address":"宁海路122","telephone":"","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师范大学美术学院陶瓷艺术研究所","address":"南京师范大学美术学院附近","telephone":"","location":{"lng":118.77077002302,"lat":32.052959806771}},{"name":"南京师大mba教育中心","address":"宁海路122","telephone":"(025)83598010","location":{"lng":118.77029969033,"lat":32.051798283464}},{"name":"南京师范大学出版社","address":"宁海路122-1","telephone":"(025)83598297","location":{"lng":118.7716101983,"lat":32.054596357149}},{"name":"南京师范大学","address":"近郊栖霞区文苑路1号南京师范大学仙林校区(近学海路)","telephone":"(025)85891111","location":{"lng":118.91053767444,"lat":32.100842038301}},{"name":"南京师范大学(南京师范大学茶苑西北)","address":"南京师范大学茶苑附近","telephone":"","location":{"lng":118.89749419942,"lat":32.100124476633}},{"name":"南京师大文化产业研究院","address":"宁海路122号","telephone":"","location":{"lng":118.76677027128,"lat":32.05341620449}},{"name":"南京师大动画教学实验室","address":"文苑路1号","telephone":"(025)85891111","location":{"lng":118.91293980185,"lat":32.103668274675}},{"name":"南京师大动感地带品牌店","address":"文苑路1号","telephone":"","location":{"lng":118.91386034804,"lat":32.11373422087}},{"name":"南京师大文教资料杂志社","address":"宁海路122号","telephone":"","location":{"lng":118.76677027128,"lat":32.05341620449}},{"name":"南京师大数理化图书馆","address":"文苑路1号","telephone":"(025)85898807","location":{"lng":118.91131993851,"lat":32.101370704782}},{"name":"南京师大实验动物中心","address":"文苑路1号","telephone":"(025)85891111","location":{"lng":118.91638979554,"lat":32.116474833066}},{"name":"南京师大老年学研究中心","address":"宁海路122","telephone":"","location":{"lng":118.77001049735,"lat":32.052155491725}},{"name":"南京师大(紫金校区)-南门","address":"板仓街78","telephone":"(025)85412341","location":{"lng":118.82176015911,"lat":32.070845574988}},{"name":"南京师大国际经济研究中心","address":"宁海路122","telephone":"","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师大幼儿教育发展中心","address":"宁海路128号南山专家楼7层","telephone":"","location":{"lng":118.76850053291,"lat":32.052734199139}},{"name":"南京师大中国经济研究中心","address":"宁海路122","telephone":"","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师大南师教育培训中心","address":"龙蟠中路317号","telephone":"(025)84868258","location":{"lng":118.80183941887,"lat":32.03041317888}},{"name":"南京师范大学图书情报管理研究所","address":"宁海路122号南京师范大学随园校区华夏图书馆1层","telephone":"(025)83598010","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师大老年体育工作者协会","address":"宁海路122","telephone":"","location":{"lng":118.77034005684,"lat":32.054443980065}},{"name":"南京师范大学环境科学研究所","address":"南京师范大学法学院附近","telephone":"","location":{"lng":118.77029969033,"lat":32.051798283464}},{"name":"南京师范大学社会发展学院","address":"宁海路","telephone":"","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师大(仙林校区)-3号门","address":"文苑路3号","telephone":"(025)85891111","location":{"lng":118.90674972446,"lat":32.098174130253}},{"name":"南京师大出版社·两江培训","address":"南京市鼓楼区","telephone":"(025)83283232","location":{"lng":118.77100978005,"lat":32.054668665478}},{"name":"南京师范大学后宰门学区","address":"后宰门西村9号","telephone":"(025)84804071","location":{"lng":118.81909959839,"lat":32.046478351732}},{"name":"南京师大学生社团联合会紫金分会","address":"板仓街78号","telephone":"","location":{"lng":118.82045021141,"lat":32.072399348362}},{"name":"南京师大(仙林校区)-1号主校门","address":"文范路1","telephone":"(025)85891111","location":{"lng":118.91263020472,"lat":32.100090985023}},{"name":"南京师范大学中北学院(学林路)","address":"南京仙林大学城学林路2号","telephone":"(025)85898048","location":{"lng":118.91000008439,"lat":32.115897456875}},{"name":"南京师大认知科学研究中心","address":"宁海路122号","telephone":"","location":{"lng":118.76596026715,"lat":32.052589616894}},{"name":"南京师范大学国际健身中心","address":"宁海路122号南京师范大学随园校区操场西侧体育馆2楼","telephone":"(025)83704511","location":{"lng":118.76596026715,"lat":32.052589616894}},{"name":"南京师范大学乳品生物技术研究所","address":"宁海路122号附近","telephone":"","location":{"lng":118.76987000731,"lat":32.051729772315}},{"name":"南京师大计算机科学与技术学院","address":"宁海路122","telephone":"(025)83598010","location":{"lng":118.76911977004,"lat":32.052845105619}},{"name":"南京师大社会工作研究与发展中心","address":"宁海路122","telephone":"","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师大音乐教育研究所","address":"宁海路122","telephone":"","location":{"lng":118.77081990226,"lat":32.052675880167}},{"name":"南京师范大学公共管理学院","address":"宁海路122号附近","telephone":"(025)83598010","location":{"lng":118.77009325504,"lat":32.052528741595}},{"name":"南京师范大学金陵营养与资源研究所","address":"宁海路122号附近","telephone":"","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师范大学附属扬子中学(水榭花苑东)","address":"杨村路146号","telephone":"","location":{"lng":118.76126115916,"lat":32.23904416039}},{"name":"师豪高校实业有限公司南京师范大学后勤实业中心","address":"文苑路1","telephone":"","location":{"lng":118.90597514248,"lat":32.099590976765}},{"name":"金门驾校（南京师范大学仙林校区报名处）","address":"南京师范大学仙林校区内","telephone":"(025)66167606,18013893689","location":{"lng":118.90795742823,"lat":32.101946287414}},{"name":"南京师大紫金校区学生第二餐厅","address":"南京玄武区板仓街78号(近南师大紫金校区)","telephone":"(025)85768899","location":{"lng":118.82188006769,"lat":32.070801725057}},{"name":"南京师大科技实业集团公司物联网包装应用材料研究所","address":"宁海路122","telephone":"","location":{"lng":118.76762038941,"lat":32.052635722885}},{"name":"南京师范大学生命科学学院遗传资源研究所","address":"南京师范大学随园校区28号楼","telephone":"(025)86083183","location":{"lng":118.76597028327,"lat":32.052482353281}},{"name":"南京师范大学法学院","address":"宁海路122南京师范大学逸夫楼","telephone":"(025)83598010","location":{"lng":118.77013031393,"lat":32.052474512836}},{"name":"南京师范大学文学院","address":"南京师范大学随园校区中大楼","telephone":"(025)83598450","location":{"lng":118.76739494533,"lat":32.053465931186}}]},"destination":{"cityName":"北京市","listType":0,"results":[{"name":"中国政法大学","address":"314路;314路;345快;345快;357路;357路;357区间;357区间;870路;870路;881路;881路;884路;884路;888快;888快;888路;888路;922路;922路;925路;925路;h63路;h63路;昌11路;昌11路;昌16路","telephone":"","location":{"lng":116.24540028074,"lat":40.22107025404}},{"name":"中国政法大学(学院路校区)","address":"海淀区西土城路25号","telephone":"(010)58909114","location":{"lng":116.35152026298,"lat":39.965765692502}},{"name":"中国政法大学(昌平校区)","address":"北京市昌平区府学路27号","telephone":"(010)58909162","location":{"lng":116.24758143785,"lat":40.222819419441}},{"name":"中国政法大学-东门","address":"北京市海淀区西土城路25号","telephone":"010-58909114","location":{"lng":116.35298127874,"lat":39.965010349286}},{"name":"中国政法大学-南门","address":"北京市海淀区西土城路25号","telephone":"010-58909114","location":{"lng":116.35172062395,"lat":39.964043105482}},{"name":"中国政法大学-北门","address":"北京市海淀区西土城路25号","telephone":"010-58909114","location":{"lng":116.35185167304,"lat":39.967012816241}},{"name":"中国政法大学校医院","address":"昌平区府学路","telephone":"(010)58909114","location":{"lng":116.35016092068,"lat":39.966345693083}},{"name":"中国政法大学医院","address":"东关路","telephone":"(010)58909228","location":{"lng":116.24755005558,"lat":40.225229615104}},{"name":"中国政法大学研究生院","address":"北京市海淀区西土城路25号法大培训区606室","telephone":"010-58908070","location":{"lng":116.3501716543,"lat":39.966718704908}},{"name":"中国政法大学司法考试学院","address":"北京市海淀区西土城路25号","telephone":"","location":{"lng":116.35302567056,"lat":39.964802550323}},{"name":"中国政法大学出版社","address":"北京市海淀区西土城路25号院5号楼","telephone":"010-58908302","location":{"lng":116.35280065402,"lat":39.9664150491}},{"name":"中国政法大学留学_政法大学","address":"北京市海淀区西土城路25号中国政法大学","telephone":"4006887125","location":{"lng":116.35299063827,"lat":39.965030970199}},{"name":"中国政法大学中国法律信息中心","address":"北京市海淀区","telephone":"","location":{"lng":116.35017646977,"lat":39.966103715419}},{"name":"中国政法大学-停车场","address":"西土城路25号附近","telephone":"","location":{"lng":116.35299027087,"lat":39.965037883995}},{"name":"中国政法大学第一食堂","address":"中国政法大学内","telephone":"(010)58909239","location":{"lng":116.24807063917,"lat":40.222604059532}},{"name":"中国政法大学篮球场","address":"北京市昌平区","telephone":"","location":{"lng":116.24786262229,"lat":40.224597477359}},{"name":"中国政法大学-停车场","address":"西土城路辅路附近","telephone":"","location":{"lng":116.35259347272,"lat":39.965035487141}},{"name":"中国政法大学门诊部","address":"北京市海淀区西土城路25号","telephone":"","location":{"lng":116.35299063827,"lat":39.965030970199}},{"name":"中国政法大学第二食堂","address":"中国政法大学内","telephone":"(010)58909239","location":{"lng":116.24921054347,"lat":40.222576543978}},{"name":"中国政法大学教育基金会","address":"北京市昌平区府学路27号中国政法大学发展规划与学科建设处","telephone":"","location":{"lng":116.24644725331,"lat":40.221373328051}},{"name":"中国政法大学第三食堂","address":"中国政法大学内","telephone":"(010)58909239","location":{"lng":116.24803007412,"lat":40.225124575975}},{"name":"中国政法大学斋8号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24415272767,"lat":40.228174468919}},{"name":"中国政法大学网球场","address":"北京市昌平区","telephone":"","location":{"lng":116.24758460452,"lat":40.224478563352}},{"name":"中国政法大学斋3号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24457248447,"lat":40.227643933114}},{"name":"中国政法大学斋5号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24469236426,"lat":40.22806869573}},{"name":"中国政法大学一食堂","address":"昌平区府学路27号","telephone":"","location":{"lng":116.24644725331,"lat":40.221373328051}},{"name":"中国政法大学医院-急诊","address":"北京市昌平区","telephone":"(010)58909227","location":{"lng":116.24741989084,"lat":40.225225072479}},{"name":"中国政法大学劳动法诊所","address":"北京市海淀区西土城路25号学院路中国政法大学正门南侧北京教育工会","telephone":"(010)62228839,(010)62260586","location":{"lng":116.35299063827,"lat":39.965030970199}},{"name":"中国政法大学6号楼","address":"北京市海淀区","telephone":"","location":{"lng":116.35269469079,"lat":39.964343388009}},{"name":"中国政法大学家属宿舍1号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24682079899,"lat":40.227473354607}},{"name":"中国政法大学家属宿舍12号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24928000732,"lat":40.226237928008}},{"name":"中国政法大学学生公寓9号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24586346816,"lat":40.225280421793}},{"name":"中国政法大学家属宿舍3号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24673756909,"lat":40.226751947191}},{"name":"中国政法大学留学服务中心","address":"昌平校区,昌平区府学路27号中国政法大学国际交流中心a座116室","telephone":"(010)58909583","location":{"lng":116.24506055761,"lat":40.223043306022}},{"name":"中国政法大学家属宿舍9号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24957102235,"lat":40.227850561384}},{"name":"中国政法大学(昌平校区)-东门","address":"北京市昌平区","telephone":"","location":{"lng":116.2500601188,"lat":40.223015517488}},{"name":"中国政法大学(昌平校区)-南门","address":"府学路27号","telephone":"(010)58909162","location":{"lng":116.24646039879,"lat":40.221283593573}},{"name":"中国政法大学停车场-出入口","address":"西土城路25号","telephone":"","location":{"lng":116.35287300898,"lat":39.965059958376}},{"name":"中国政法大学家属宿舍4号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24683001235,"lat":40.226392287523}},{"name":"中国政法大学家属宿舍11号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24957080414,"lat":40.226810969839}},{"name":"中国政法大学家属宿舍6号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24843575441,"lat":40.227595741973}},{"name":"中国政法大学家属宿舍10号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24954213809,"lat":40.227493078518}},{"name":"中国政法大学家属宿舍2号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24671364831,"lat":40.227110380853}},{"name":"中国政法大学家属宿舍5号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24690402712,"lat":40.226012303052}},{"name":"中国政法大学家属宿舍8号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.2466679079,"lat":40.227806557541}},{"name":"中国政法大学家属宿舍7号楼","address":"北京市昌平区","telephone":"","location":{"lng":116.24796013057,"lat":40.227315176044}},{"name":"中国政法大学-继续教育学院","address":"西土城路25中国政法大学","telephone":"","location":{"lng":116.35062103162,"lat":39.966797340775}},{"name":"中国政法大学(昌平校区)-北门","address":"县城东关路","telephone":"","location":{"lng":116.24768034751,"lat":40.224745341156}},{"name":"中国政法大学运输服务中心","address":"北三环西路辅路明光北里(北二门)附近","telephone":"","location":{"lng":116.35164484944,"lat":39.967015005851}},{"name":"中国政法大学国际交流中心","address":"东关路5号院13号","telephone":"(010)59915588","location":{"lng":116.24821959932,"lat":40.225258846643}}]}}
\ No newline at end of file
diff --git a/bin/test.unicode.json b/bin/test.unicode.json
new file mode 100644
index 0000000..a2c4926
Binary files /dev/null and b/bin/test.unicode.json differ
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/CMOV.inc" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/CMOV.inc"
new file mode 100644
index 0000000..edf4e19
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/CMOV.inc"
@@ -0,0 +1,30 @@
+{˵
+ʹ YxdInclude Ӧ븴CMOVԼĸĿ¼}
+
+{.$DEFINE USE_DEBUGMODE} // Ƿʹõģʽ
+
+{$IFDEF USE_DEBUGMODE}
+ {$DEFINE DebugApp} // õ״̬
+{$ENDIF}
+
+{$DEFINE OuputFileLog} //Ƿ־ļ
+{.$DEFINE OuputRemoteLog} //ǷԶ־Ϣ
+
+{$IFDEF DebugApp}
+ {$DEFINE WRITEDEBUG} //ǷдϢ
+ {$DEFINE OutputDebug} //ǷϢϢ
+{$ENDIF}
+
+{YxdCommon}
+{$DEFINE USE_URLFUNC} // ǷʹURL
+
+{YxdHTTP}
+{.$DEFINE USE_CoXml} // ǷʹCoXMLʽGetPOST
+
+{YxdPerisistent}
+{$DEFINE USE_DBREADWRITE} // ǷԴݿж
+{$DEFINE USE_XMLREADWRITE} // ǷʹXMLд
+{$DEFINE USE_JSONREADWRITE} // ǷʹJSONд
+
+
+
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.dpr" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.dpr"
new file mode 100644
index 0000000..59a2232
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.dpr"
@@ -0,0 +1,15 @@
+program JSON_DataSet_Serialize_2007;
+
+uses
+ Forms,
+ Unit1 in 'Unit1.pas' {Form1};
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.dproj" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.dproj"
new file mode 100644
index 0000000..4dd23e8
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.dproj"
@@ -0,0 +1,143 @@
+
+
+
+ {cc48b93a-3e6b-4fe0-92f9-869afc3ef4c1}
+ Debug
+ AnyCPU
+ DCC32
+ ..\..\..\bin\JSON_DataSet_Serialize_2007.exe
+ JSON_DataSet_Serialize_2007.dpr
+
+
+ 7.0
+ False
+ False
+ 0
+ RELEASE
+
+
+ 7.0
+ DEBUG
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+
+
+ Delphi.Personality
+
+
+FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse20529361.0.0.01.0.0.0
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ CodeGear C++Builder Office 2000 Servers Package
+ CodeGear C++Builder Office XP Servers Package
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+ JSON_DataSet_Serialize_2007.dpr
+
+
+
+
+
+
+
+ 'D:\Program Files\Autodesk\3ds Max 2014\'
+ 'C:\ProgramData'
+ 'D:\Program Files\Java\Android\android-sdk'
+ 'D:\'
+ 'C:\Users\Administrator\AppData\Roaming'
+ 'd:\program files (x86)\codegear\rad studio\5.0'
+ 'C:\Users\Public\Documents\RAD Studio\5.0'
+ 'D:\My Documents\Documents\RAD Studio\Projects'
+ 'D:\My Documents\Documents\RAD Studio\5.0'
+ 'D:\Program Files\Java\jdk1.7.0\lib;D:\Program Files\Java\jdk1.7.0\lib\tools.jar'
+ 'C:\Program Files (x86)\Common Files\Autodesk Shared\Materials\'
+ 'C:\Program Files (x86)\Common Files'
+ 'C:\Program Files (x86)\Common Files'
+ 'C:\Program Files\Common Files'
+ 'YANGYXD-HOME'
+ 'C:\Windows\system32\cmd.exe'
+ 'd:\program files (x86)\codegear\rad studio\5.0'
+ 'C:\Program Files (x86)\Microsoft DirectX SDK (March 2009)\'
+ 'NO'
+ 'C:'
+ '\Users\Administrator'
+ 'C:\Program Files (x86)\Common Files\Autodesk Shared\Materials\'
+ 'C:\Program Files (x86)\Common Files\Autodesk Shared\Materials\'
+ 'D:\Program Files\Java\jdk1.7.0'
+ 'C:\Users\Administrator\AppData\Local'
+ '\\YANGYXD-HOME'
+ '8'
+ 'Windows_NT'
+ 'C:\Program Files\Common Files\Microsoft Shared\Windows Live;d:\Program Files (x86)\CodeGear\RAD Studio\5.0\bin;C:\Users\Public\Documents\RAD Studio\5.0\Bpl;C:\Program Files (x86)\NVIDIA Corporation\PhysX\Common;C:\Windows\system32;C:\Windows;C:\Windows\System32\Wbem;C:\Windows\System32\WindowsPowerShell\v1.0\;C:\Program Files (x86)\Common Files\Thunder Network\KanKan\Codecs;C:\Program Files (x86)\Microsoft SQL Server\100\Tools\Binn\;C:\Program Files\Microsoft SQL Server\100\Tools\Binn\;C:\Program Files\Microsoft SQL Server\100\DTS\Binn\;D:\Program Files\Java\jdk1.7.0\bin;D:\Program Files\Java\jdk1.7.0\jre\bin;D:\Program Files\Java\Android\android-sdk\tools;D:\Program Files\Java\Android\android-sdk\;D:\Program Files\Java\Android\android-sdk\platform-tools;C:\Program Files (x86)\Common Files\Autodesk Shared\;C:\Program Files (x86)\backburner 2\;C:\Program Files\Common Files\Autodesk Shared\;C:\Program Files (x86)\Autodesk\Backburner\;C:\Program Files (x86)\Microsoft SQL Server\100\Tools\Binn\VSShell\Common7\IDE\;C:\Program Files (x86)\Microsoft SQL Server\100\DTS\Binn\;C:\Program Files (x86)\Microsoft Visual Studio 9.0\Common7\IDE\PrivateAssemblies\;C:\Users\Public\Documents\Embarcadero\Studio\14.0\Bpl;%CommonProgramFiles%\Microsoft Shared\Windows Live;C:\Users\Public\Documents\RAD Studio\5.0\Bpl'
+ '.COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC'
+ 'x86'
+ 'AMD64'
+ 'Intel64 Family 6 Model 58 Stepping 9, GenuineIntel'
+ '6'
+ '3a09'
+ 'C:\ProgramData'
+ 'C:\Program Files (x86)'
+ 'C:\Program Files (x86)'
+ 'C:\Program Files'
+ 'C:\Windows\system32\WindowsPowerShell\v1.0\Modules\'
+ 'C:\Users\Public'
+ 'Console'
+ 'C:'
+ 'C:\Windows'
+ 'C:\Users\ADMINI~1\AppData\Local\Temp'
+ 'C:\Users\ADMINI~1\AppData\Local\Temp'
+ 'YANGYXD-HOME'
+ 'Administrator'
+ 'C:\Users\Administrator'
+ 'D:\Program Files\Microsoft Visual Studio 10.0\Common7\Tools\'
+ 'C:\Windows'
+ '3'
+ 'C:\BVTBin\Tests\installpackage\csilogfile.log'
+
+
+
+
+
+
+ MainSource
+
+
+
+
+
+
+
\ No newline at end of file
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.res" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.res"
new file mode 100644
index 0000000..e877da3
Binary files /dev/null and "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_2007.res" differ
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.dpr" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.dpr"
new file mode 100644
index 0000000..df43e7c
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.dpr"
@@ -0,0 +1,15 @@
+program JSON_DataSet_Serialize_XE6;
+
+uses
+ Vcl.Forms,
+ Unit1 in 'Unit1.pas' {Form1};
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.dproj" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.dproj"
new file mode 100644
index 0000000..408da97
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.dproj"
@@ -0,0 +1,149 @@
+
+
+ {FBE7FC34-5581-4645-A4A3-71E9B2BF28A1}
+ 15.4
+ VCL
+ JSON_DataSet_Serialize_XE6.dpr
+ True
+ Release
+ Win32
+ 1
+ Application
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_1
+ true
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_2
+ true
+ true
+
+
+ $(BDS)\bin\delphi_PROJECTICON.ico
+ JSON_DataSet_Serialize_XE6
+ System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)
+ .\$(Platform)\$(Config)
+ .\$(Platform)\$(Config)
+ false
+ false
+ false
+ false
+ false
+
+
+ true
+ 1033
+ FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;inetdbbde;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapServer;DataSnapCommon;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;RESTBackendComponents;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;vclactnband;bindengine;soaprtl;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;DBXInformixDriver;Intraweb;VCLRESTComponents;DataSnapConnectors;DataSnapServerMidas;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;dbexpress;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage)
+ $(BDS)\bin\default_app.manifest
+ Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
+
+
+ FireDACSqliteDriver;FireDACDSDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;tethering;vclib;DBXInterBaseDriver;DataSnapClient;DataSnapServer;DataSnapCommon;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;DBXMSSQLDriver;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;DataSnapFireDAC;FireDACDBXDriver;soapserver;inetdbxpress;dsnapxml;FireDACInfxDriver;FireDACDb2Driver;adortl;FireDACASADriver;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;DataSnapNativeClient;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;vclactnband;bindengine;soaprtl;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;DBXInformixDriver;Intraweb;VCLRESTComponents;DataSnapConnectors;DataSnapServerMidas;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;FireDACMSAccDriver;dbexpress;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage)
+
+
+ DEBUG;$(DCC_Define)
+ true
+ false
+ true
+ true
+ true
+
+
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ ..\..\..\bin
+ ..\..\..\dcu
+ true
+ 1033
+ false
+
+
+ false
+ RELEASE;$(DCC_Define)
+ 0
+ 0
+
+
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\bin
+ ..\..\..\dcu
+ true
+ 1033
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+
+
+
+ MainSource
+
+
+
+ dfm
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+ Delphi.Personality.12
+
+
+
+
+ JSON_DataSet_Serialize_XE6.dpr
+
+
+ Embarcadero C++Builder Office 2000 Servers Package
+ Embarcadero C++Builder Office XP Servers Package
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+
+
+
+
+ True
+ False
+
+
+ 12
+
+
+
+
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.res" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.res"
new file mode 100644
index 0000000..d6cf632
Binary files /dev/null and "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/JSON_DataSet_Serialize_XE6.res" differ
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Project1.res" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Project1.res"
new file mode 100644
index 0000000..d6cf632
Binary files /dev/null and "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Project1.res" differ
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Unit1.dfm" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Unit1.dfm"
new file mode 100644
index 0000000..2dd74b3
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Unit1.dfm"
@@ -0,0 +1,316 @@
+object Form1: TForm1
+ Left = 0
+ Top = 0
+ Caption = 'Form1'
+ ClientHeight = 747
+ ClientWidth = 1120
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Tahoma'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCreate = FormCreate
+ PixelsPerInch = 96
+ TextHeight = 13
+ object Splitter1: TSplitter
+ Left = 0
+ Top = 343
+ Width = 1120
+ Height = 9
+ Cursor = crVSplit
+ Align = alBottom
+ ExplicitTop = 456
+ end
+ object DBGrid1: TDBGrid
+ Left = 0
+ Top = 105
+ Width = 1120
+ Height = 238
+ Align = alClient
+ DataSource = DataSource1
+ TabOrder = 0
+ TitleFont.Charset = DEFAULT_CHARSET
+ TitleFont.Color = clWindowText
+ TitleFont.Height = -11
+ TitleFont.Name = 'Tahoma'
+ TitleFont.Style = []
+ end
+ object Panel1: TPanel
+ Left = 0
+ Top = 0
+ Width = 1120
+ Height = 105
+ Align = alTop
+ BevelOuter = bvNone
+ TabOrder = 1
+ DesignSize = (
+ 1120
+ 105)
+ object Label1: TLabel
+ Left = 6
+ Top = 10
+ Width = 72
+ Height = 13
+ Caption = #27979#35797#25968#25454#24211#65306
+ end
+ object Button1: TButton
+ Left = 8
+ Top = 34
+ Width = 75
+ Height = 25
+ Anchors = [akTop, akRight]
+ Caption = 'ToDataSet'
+ TabOrder = 0
+ OnClick = Button1Click
+ end
+ object Button2: TButton
+ Left = 87
+ Top = 34
+ Width = 75
+ Height = 25
+ Anchors = [akTop, akRight]
+ Caption = 'ToDataSet'
+ TabOrder = 1
+ OnClick = Button2Click
+ end
+ object Button4: TButton
+ Left = 281
+ Top = 34
+ Width = 75
+ Height = 25
+ Anchors = [akTop, akRight]
+ Caption = #21152#36733#25968#25454
+ TabOrder = 2
+ OnClick = Button4Click
+ end
+ object Button3: TButton
+ Left = 168
+ Top = 34
+ Width = 75
+ Height = 25
+ Anchors = [akTop, akRight]
+ Caption = 'PutDataSet'
+ TabOrder = 3
+ OnClick = Button3Click
+ end
+ object Edit1: TEdit
+ Left = 84
+ Top = 7
+ Width = 565
+ Height = 21
+ TabOrder = 4
+ Text = 'E:\Users Folder\Desktop\db2.mdb'
+ end
+ object Button5: TButton
+ Left = 362
+ Top = 34
+ Width = 75
+ Height = 25
+ Caption = #20445#23384'Data'
+ TabOrder = 5
+ OnClick = Button5Click
+ end
+ object CheckBox1: TCheckBox
+ Left = 680
+ Top = 9
+ Width = 145
+ Height = 17
+ Caption = 'Base64 '#32534#30721' Blob'
+ Checked = True
+ State = cbChecked
+ TabOrder = 6
+ end
+ object Button7: TButton
+ Left = 191
+ Top = 65
+ Width = 177
+ Height = 25
+ Caption = #19982#28784#32418'QDBJson'#21453#24207#21015#21270#23545#27604
+ TabOrder = 7
+ OnClick = Button7Click
+ end
+ object Button8: TButton
+ Left = 384
+ Top = 65
+ Width = 153
+ Height = 25
+ Caption = #19982'AdoStream'#24207#21015#21270#23545#27604
+ TabOrder = 8
+ OnClick = Button8Click
+ end
+ object Button9: TButton
+ Left = 543
+ Top = 65
+ Width = 162
+ Height = 25
+ Caption = #19982'AdoStream'#21453#24207#21015#21270#23545#27604
+ TabOrder = 9
+ OnClick = Button9Click
+ end
+ end
+ object Button6: TButton
+ Left = 8
+ Top = 65
+ Width = 177
+ Height = 25
+ Caption = #19982#28784#32418'QDBJson'#24207#21015#21270#23545#27604
+ TabOrder = 2
+ OnClick = Button6Click
+ end
+ object PageControl1: TPageControl
+ Left = 0
+ Top = 352
+ Width = 1120
+ Height = 395
+ ActivePage = TabSheet1
+ Align = alBottom
+ TabOrder = 3
+ object TabSheet1: TTabSheet
+ Caption = 'YxdJson'
+ object Memo1: TMemo
+ Left = 0
+ Top = 0
+ Width = 1112
+ Height = 367
+ Align = alClient
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -12
+ Font.Name = 'Courier New'
+ Font.Style = []
+ HideSelection = False
+ Lines.Strings = (
+ '{'
+ ' "rows": ['
+ ' {'
+ ' "FInterID": 22087,'
+ ' "FBillNo": "XSD20140722000441",'
+ ' "FDate": "2014-07-11T00:00:00",'
+ ' "FSupplyID": 36,'
+ ' "FMerchandizerID": 5,'
+ ' "FQCID": 5,'
+ ' "FDelDate": "2013-12-31T00:00:00",'
+ ' "FShipmentID": 10,'
+ ' "FDocumentoryID": 5,'
+ ' "FNote": "gh",'
+ ' "FFilePath": "",'
+ ' "FModifyTime": "1900-01-01T00:00:00",'
+ ' "FProgramID": 0,'
+ ' "FCreateUser": 1,'
+ ' "techDate": null,'
+ ' "loadingDate": null,'
+ ' "factoryDelDate": null,'
+ ' "FQty": null,'
+ ' "Price": null,'
+ ' "FQCID2": 1,'
+ ' "FContact": "42",'
+ ' "FTranType": 0,'
+ ' "FPhone": "12",'
+ ' "FAddress": "",'
+ ' "FSupplierName": "321",'
+ ' "MerchandizerName": "13",'
+ ' "FQCName": "13",'
+ ' "FDocumentoryName": "13",'
+ ' "FShipmentName": "[blobs]<123456>"'
+ ' },'
+ ' {'
+ ' "FInterID": 22124,'
+ ' "FBillNo": "XSD20140722000447",'
+ ' "FDate": "2014-07-22T00:00:00",'
+ ' "FSupplyID": 36,'
+ ' "FMerchandizerID": 5,'
+ ' "FQCID": 5,'
+ ' "FDelDate": "2014-07-24T00:00:00",'
+ ' "FShipmentID": 0,'
+ ' "FDocumentoryID": 5,'
+ ' "FNote": "",'
+ ' "FFilePath": "",'
+ ' "FModifyTime": "1900-01-01T00:00:00",'
+ ' "FProgramID": 0,'
+ ' "FCreateUser": 1,'
+ ' "techDate": "2014-07-10T00:00:00",'
+ ' "loadingDate": "2014-07-24T00:00:00",'
+ ' "factoryDelDate": "2014-07-31T00:00:00",'
+ ' "FQty": 321,'
+ ' "Price": 17859,'
+ ' "FQCID2": 1,'
+ ' "FContact": "37",'
+ ' "FTranType": 0,'
+ ' "FPhone": "2",'
+ ' "FAddress": "12312",'
+ ' "FSupplierName": "321",'
+ ' "MerchandizerName": "13",'
+ ' "FQCName": "13",'
+ ' "FDocumentoryName": "13",'
+ ' "FShipmentName": null'
+ ' }'
+ ' ],'
+ ' "total": 2'
+ '}'
+ '')
+ ParentFont = False
+ ScrollBars = ssBoth
+ TabOrder = 0
+ OnKeyDown = Memo1KeyDown
+ end
+ end
+ object TabSheet2: TTabSheet
+ Caption = 'QDBJson'
+ ImageIndex = 1
+ ExplicitLeft = 0
+ ExplicitTop = 0
+ ExplicitWidth = 0
+ ExplicitHeight = 0
+ object Memo2: TMemo
+ Left = 0
+ Top = 0
+ Width = 1112
+ Height = 367
+ Align = alClient
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -12
+ Font.Name = 'Courier New'
+ Font.Style = []
+ HideSelection = False
+ ParentFont = False
+ ScrollBars = ssBoth
+ TabOrder = 0
+ end
+ end
+ end
+ object Button10: TButton
+ Left = 462
+ Top = 34
+ Width = 107
+ Height = 25
+ Caption = #35835#21462'Json'#25991#20214
+ TabOrder = 4
+ OnClick = Button10Click
+ end
+ object ClientDataSet1: TClientDataSet
+ Aggregates = <>
+ Params = <>
+ Left = 280
+ Top = 104
+ end
+ object DataSource1: TDataSource
+ DataSet = ClientDataSet1
+ Left = 312
+ Top = 104
+ end
+ object OpenDialog1: TOpenDialog
+ Filter = '*.json|*.json;*.txt|*.*|*.*'
+ Left = 280
+ Top = 160
+ end
+ object FindDialog1: TFindDialog
+ OnShow = FindDialog1Show
+ Options = [frDown, frHideMatchCase, frHideWholeWord, frHideUpDown]
+ OnFind = FindDialog1Find
+ Left = 312
+ Top = 160
+ end
+end
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Unit1.pas" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Unit1.pas"
new file mode 100644
index 0000000..78b3c00
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/Unit1.pas"
@@ -0,0 +1,533 @@
+unit Unit1;
+
+interface
+
+uses
+ StrUtils, YxdAdoStream,
+ Windows, Messages, SysUtils, Variants, Classes, Graphics,
+ Controls, Forms, Dialogs, StdCtrls, DB, ADODB, ActiveX, Grids,
+ DBGrids, DBClient, ExtCtrls, ComCtrls;
+
+type
+ TForm1 = class(TForm)
+ ClientDataSet1: TClientDataSet;
+ DBGrid1: TDBGrid;
+ DataSource1: TDataSource;
+ Panel1: TPanel;
+ Button1: TButton;
+ Button2: TButton;
+ Button4: TButton;
+ Button3: TButton;
+ Label1: TLabel;
+ Edit1: TEdit;
+ Splitter1: TSplitter;
+ CheckBox1: TCheckBox;
+ Button6: TButton;
+ PageControl1: TPageControl;
+ TabSheet1: TTabSheet;
+ Memo1: TMemo;
+ TabSheet2: TTabSheet;
+ Memo2: TMemo;
+ Button7: TButton;
+ Button8: TButton;
+ Button9: TButton;
+ Button10: TButton;
+ OpenDialog1: TOpenDialog;
+ FindDialog1: TFindDialog;
+ procedure Button1Click(Sender: TObject);
+ procedure Button2Click(Sender: TObject);
+ procedure Button3Click(Sender: TObject);
+ procedure Button4Click(Sender: TObject);
+ procedure Button5Click(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure Button6Click(Sender: TObject);
+ procedure Button7Click(Sender: TObject);
+ procedure Button8Click(Sender: TObject);
+ procedure Button9Click(Sender: TObject);
+ procedure Button10Click(Sender: TObject);
+ procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+ procedure FindDialog1Show(Sender: TObject);
+ procedure FindDialog1Find(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+var
+ // λ
+ SoftPath: string;
+
+implementation
+
+{$R *.dfm}
+
+
+uses YxdJson{$IFDEF UNICODE}, uQDBJson{$ENDIF};
+
+type
+ TJsonArrayHelper = class helper for JSONArray
+ public
+ procedure ToDataSet(DataSet: TClientDataSet);
+ end;
+
+ { TJsonArrayHelper }
+
+procedure TJsonArrayHelper.ToDataSet(DataSet: TClientDataSet);
+var
+ ii, j: Integer;
+ lItem: JSONObject;
+ lValue: PJSONValue;
+ lList: TStringList;
+ lName: string;
+begin
+
+ with DataSet do
+ begin
+ FieldDefs.Clear;
+ Close;
+
+ if self.count - 1 < 0 then
+ Exit;
+
+ lList := TStringList.Create;
+ lItem := self.getJsonObject(0);
+
+ for ii := 0 to lItem.count - 1 do
+ lList.Add(lItem.Items[ii].FName); // ֶ֪䵽List
+
+ // ѭֱн
+ while lList.count - 1 >= 0 do
+ begin
+
+ for ii := 0 to self.count - 1 do
+ begin
+ lItem := self.getJsonObject(ii);
+ for j := 0 to lItem.count - 1 do
+ begin
+ lValue := lItem.Items[j];
+
+ // ֶδھ
+ if FieldDefs.IndexOf(lValue.FName) >= 0 then
+ Continue;
+
+ case lValue.FType of
+ jdtString:
+ FieldDefs.Add(lValue.FName, ftString, 200);
+ jdtInteger:
+ FieldDefs.Add(lValue.FName, ftInteger);
+ jdtFloat:
+ FieldDefs.Add(lValue.FName, ftFloat);
+ jdtBoolean:
+ FieldDefs.Add(lValue.FName, ftBoolean);
+ jdtDateTime:
+ FieldDefs.Add(lValue.FName, ftDateTime);
+ end;
+
+ // ֪ʹӶƳ
+ if lValue.FType in [jdtString, jdtInteger, jdtFloat, jdtBoolean, jdtDateTime] then
+ begin
+ lList.Delete(lList.IndexOf(lValue.FName));
+ end;
+
+ end;
+ end;
+ end;
+
+ // лֶ
+ for lName in lList do
+ begin
+ if Length(lName) > 0 then
+ FieldDefs.Add(lName, ftVariant);
+ end;
+
+
+ CreateDataSet;
+ for ii := 0 to self.count - 1 do
+ begin
+ lItem := self.getJsonObject(ii);
+
+ Append;
+
+ for j := 0 to lItem.count - 1 do
+ begin
+ lValue := lItem.Items[j];
+ case lValue.FType of
+ jdtString:
+ FieldByName(lValue.FName).AsString := lValue.AsString;
+ jdtInteger:
+ FieldByName(lValue.FName).AsInteger := lValue.AsInteger;
+ jdtFloat:
+ FieldByName(lValue.FName).AsFloat := lValue.AsFloat;
+ jdtBoolean:
+ FieldByName(lValue.FName).AsBoolean := lValue.AsBoolean;
+ jdtDateTime:
+ FieldByName(lValue.FName).AsDateTime := lValue.AsDateTime;
+ jdtNull:
+ FieldByName(lValue.FName).AsVariant := Null;
+ end;
+ end;
+
+ post;
+ end;
+
+ lList.Free;
+ end;
+end;
+
+procedure TForm1.Button10Click(Sender: TObject);
+var
+ json: JSONObject;
+ I: Integer;
+ t: Cardinal;
+begin
+ if OpenDialog1.Execute(Self.Handle) then begin
+ t := GetTickCount;
+ json := JSONObject.Create;
+ try
+ json.LoadFromFile(OpenDialog1.FileName);
+ Memo1.Text := json.ToString(4);
+ I := json.ToDataSet(ClientDataSet1);
+ finally
+ json.Free;
+ end;
+ t := GetTickCount - t;
+ ShowMessage(Format('%s'#13'ļسɹ, %d, ʱ %dms.',
+ [OpenDialog1.FileName, i, t]));
+ end;
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+ lObject: JSONObject;
+ lArray: JSONArray;
+begin
+ lObject := JSONObject.parseObject(Memo1.Text);
+ lArray := lObject.getJsonArray('rows');
+ lArray.ToDataSet(ClientDataSet1);
+ lObject.Free;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+var
+ lObject: JSONObject;
+ t: Cardinal;
+begin
+ lObject := JSONObject.ParseObject(Memo1.Text);
+ t := GetTickCount;
+ lObject.ToDataSet(ClientDataSet1);
+ t := GetTickCount - t;
+ lObject.Free;
+ ShowMessage('ToDataSet ' + IntToStr(t) + 'ms.');
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+var
+ lObject: JSONObject;
+begin
+ lObject := JSONObject.Create;
+ //lObject.PutDataSet('', ClientDataSet1);
+ lObject.PutDataSet('', ClientDataSet1, 0, 0, CheckBox1.Checked);
+ Memo1.Text := lObject.ToString(4);
+ lObject.Free;
+end;
+
+var
+ Conn: TADOConnection = nil; //ݿ
+function GetLinkStr(const dbFile: string): string;
+begin
+ Result := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+dbFile+';Persist Security Info=False';
+end;
+
+procedure UnitADO(var Rs: TADOQuery);
+begin
+ try
+ if Rs <> nil then begin
+ Rs.Close; FreeAndNil(Rs);
+ end;
+ except
+ end;
+ FreeAndNil(Conn);
+end;
+
+procedure InitADO(var Rs: TADOQuery);
+begin
+ UnitADO(Rs);
+ CoInitialize(Form1);
+ Conn := TADOConnection.Create(Form1);
+ Conn.ConnectionString := GetLinkStr(Form1.Edit1.Text);
+ Conn.Open;
+ Rs := TADOQuery.Create(Form1);
+ Rs.Connection := Conn;
+end;
+
+procedure TForm1.Button4Click(Sender: TObject);
+var
+ Rs: TADOQuery;
+ JSON: JSONObject;
+ t: Cardinal;
+begin
+ try
+ InitADO(Rs);
+ t := GetTickCount;
+ JSON := JSONObject.Create;
+ Rs.SQL.Text := 'Select * from TBApp';
+ Rs.Open;
+ Json.PutDataSet('', Rs, 0, 0, CheckBox1.Checked);
+ t := GetTickCount - t;
+ Memo1.Text := Json.ToString(4);
+ ShowMessage('PutDataSet ' + IntToStr(t) + 'ms.');
+ finally
+ Rs.SaveToFile(SoftPath + 'tbapp_ado.xml', pfXML);
+ UnitADO(Rs);
+ FreeAndNil(JSON);
+ end;
+end;
+
+procedure TForm1.Button5Click(Sender: TObject);
+begin
+ if not ClientDataSet1.Active then begin
+ ShowMessage('ȼ, ToDataSet л.');
+ Exit;
+ end;
+ if ClientDataSet1.RecordCount > 0 then begin
+ TBlobField(ClientDataSet1.FieldByName('Data')).SavetoFile(SoftPath +
+ ClientDataSet1.FieldByName('Name').AsString);
+ ShowMessage('Ѿļ' + SoftPath +
+ ClientDataSet1.FieldByName('Name').AsString);
+ end;
+end;
+
+procedure TForm1.Button6Click(Sender: TObject);
+var
+ Rs: TADOQuery;
+ JSON: JSONObject;
+ {$IFDEF UNICODE}QDBJson: TQDBJson; {$ENDIF}
+ t, t1: Cardinal;
+ s{$IFDEF UNICODE},s1{$ENDIF}: string;
+begin
+ try
+ InitADO(Rs);
+ Rs.SQL.Text := 'Select * from TBApp';
+ Rs.Open;
+ Rs.First;
+
+ try
+ t := GetTickCount;
+ JSON := JSONObject.Create;
+ Json.PutDataSet('', Rs, 0, 0, CheckBox1.Checked);
+ s := Json.ToString(4);
+ t := GetTickCount - t;
+ finally
+ FreeAndNil(JSON);
+ end;
+
+ {$IFDEF UNICODE}
+ Rs.First;
+ try
+ t1 := GetTickCount;
+ QDBJson := TQDBJson.Create;
+ QDBJson.DataSet2Json(Rs, True, True, False, CheckBox1.Checked, 0, 0, [], True);
+ s1 := QDBJson.ToString;
+ t1 := GetTickCount - t1;
+ finally
+ FreeAndNil(QDBJson);
+ end;
+ {$ENDIF}
+
+ Memo1.Text := s;
+ {$IFDEF UNICODE}
+ Memo2.Text := s1;
+ {$ELSE}
+ t1 := 0;
+ {$ENDIF}
+ ShowMessage(Format('лԱȣ'#13'YxdJson %dms.'#13'QDBJson %dms.', [t, t1]));
+ finally
+ UnitADO(Rs);
+ end;
+end;
+
+procedure TForm1.Button7Click(Sender: TObject);
+{$IFDEF UNICODE}
+var
+ lObject: TQDBJson;
+ t: Cardinal;
+begin
+ t := GetTickCount;
+ TQDBJson.Json2DataSet(ClientDataSet1, Memo1.Text, nil);
+ t := GetTickCount - t;
+ lObject.Free;
+ ShowMessage('TQDBJson.Json2DataSet ' + IntToStr(t) + 'ms.');
+{$ELSE}
+begin
+{$ENDIF}
+end;
+
+procedure TForm1.Button8Click(Sender: TObject);
+var
+ Rs: TADOQuery;
+ JSON: JSONObject;
+ M: TMemoryStream;
+ t, t1, t2: Cardinal;
+ s, s1: string;
+ i: Integer;
+begin
+ try
+ InitADO(Rs);
+ Rs.SQL.Text := 'Select * from TBApp';
+ Rs.Open;
+ Rs.First;
+
+ try
+ t := GetTickCount;
+ JSON := JSONObject.Create;
+ for i := 0 to 100 do begin
+ json.Clear;
+ Json.PutDataSet('', Rs, 0, 0, CheckBox1.Checked);
+ end;
+ json.SaveToFile(SoftPath + 'tbapp.json');
+ t := GetTickCount - t;
+ s := Json.ToString(4);
+ JSON.Parse(S);
+ JSON.ToDataSet(ClientDataSet1);
+ finally
+ FreeAndNil(JSON);
+ end;
+
+ Rs.First;
+ try
+ t1 := GetTickCount;
+ M := TMemoryStream.Create;
+ for i := 0 to 100 do begin
+ M.Clear;
+ YxdAdoStream.DataSetToStream(Rs, M);
+ end;
+ m.SaveToFile(SoftPath + 'tbapp.data');
+ t1 := GetTickCount - t1;
+ finally
+ FreeAndNil(M);
+ end;
+
+ ClientDataSet1.First;
+ t2 := GetTickCount;
+ for i := 0 to 100 do begin
+ s1 := '';
+ s1 := ClientDataSet1.XMLData;
+ end;
+ ClientDataSet1.SaveToFile(SoftPath + 'tbapp.xml', dfXML);
+ t2 := GetTickCount - t2;
+
+
+ Memo1.Text := s;
+ Memo2.Text := s1;
+ ShowMessage(Format('лԱȣ'#13'YxdJson %dms.'#13'AdoStream %dms.'#13+
+ 'ClientDataSet1.XMLData %dms.', [t, t1, t2]));
+ finally
+ UnitADO(Rs);
+ end;
+end;
+
+procedure TForm1.Button9Click(Sender: TObject);
+var
+ Rs: TADOQuery;
+ JSON: JSONObject;
+ M: TMemoryStream;
+ t, t1, t2: Cardinal;
+ s, s1: string;
+ i: Integer;
+begin
+ DBGrid1.Visible := False;
+ try
+ try
+ InitADO(Rs);
+ Rs.SQL.Text := 'Select * from TBApp';
+ Rs.Open;
+ Rs.First;
+
+ try
+ JSON := JSONObject.Create;
+ Json.PutDataSet('', Rs, 0, 0, CheckBox1.Checked);
+ s := Json.ToString;
+ t := GetTickCount;
+ for i := 1 to 100 do begin
+ json.ToDataSet(ClientDataSet1);
+ end;
+ t := GetTickCount - t;
+ finally
+ FreeAndNil(JSON);
+ end;
+
+ M := TMemoryStream.Create;
+ YxdAdoStream.DataSetToStream(Rs, M);
+
+ finally
+ UnitADO(Rs);
+ end;
+
+ Rs := TADOQuery.Create(Self);
+ try
+ t1 := GetTickCount;
+ for i := 1 to 100 do begin
+ M.Position := 0;
+ YxdAdoStream.StreamToDataSet(M, Rs);
+ end;
+ t1 := GetTickCount - t1;
+ finally
+ FreeAndNil(M);
+ Rs.Free;
+ end;
+
+ ClientDataSet1.First;
+ s1 := ClientDataSet1.XMLData;
+ t2 := GetTickCount;
+ ClientDataSet1.DisableControls;
+ for i := 1 to 100 do begin
+ ClientDataSet1.XMLData := s1;
+ end;
+ ClientDataSet1.EnableControls;
+ t2 := GetTickCount - t2;
+ ClientDataSet1.SaveToFile(SoftPath + 'tbapp.xml', dfXML);
+
+ ShowMessage(Format('лԱȣ'#13'YxdJson %dms.'#13'AdoStream %dms.'#13+
+ 'ClientDataSet1.XMLData %dms.', [t, t1, t2]));
+ finally
+ DBGrid1.Visible := True;
+ end;
+end;
+
+procedure TForm1.FindDialog1Find(Sender: TObject);
+var
+ I: Integer;
+begin
+ I := PosEx(FindDialog1.FindText, Memo1.Text, Memo1.SelStart + 2);
+ if I > 0 then begin
+ Memo1.SelStart := I - 1;
+ Memo1.SelLength := Length(FindDialog1.FindText);
+ end;
+end;
+
+procedure TForm1.FindDialog1Show(Sender: TObject);
+begin
+ FindDialog1.FindText := Memo1.SelText;
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ Edit1.Text := SoftPath + 'db2.mdb';
+ OpenDialog1.InitialDir := SoftPath;
+end;
+
+procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+begin
+ if (ssCtrl in Shift) and (Key = Ord('F')) then begin
+ FindDialog1.Execute(Self.Handle);
+ end;
+end;
+
+initialization
+ SoftPath := ExtractFilePath(ParamStr(0));
+
+end.
diff --git "a/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/uQDBJson.pas" "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/uQDBJson.pas"
new file mode 100644
index 0000000..d97faa4
--- /dev/null
+++ "b/demo/YxdJson/JSON\344\270\216\346\225\260\346\215\256\351\233\206\344\272\222\350\275\254/uQDBJson.pas"
@@ -0,0 +1,1027 @@
+{*******************************************************}
+{ }
+{ QJSONݼת }
+{ }
+{ Ȩ (C) 2014 ˮ }
+{ ߣֺ QQ11241450 }
+{ QJSONȨ QDACQQȺΪ:250530692 }
+{ }
+{ V1.0.1 - 2014.07.01 }
+{*******************************************************}
+
+unit uQDBJson;
+
+interface
+
+uses SysUtils, classes, Variants, DB, Qjson;
+
+type
+
+ TQDBJson = class
+ private
+ class function ISOStr2DateTime(DateStr: string): TDateTime;
+ class function Variant2Bytes(V: Variant): TBytes;
+ class function Bytes2Variant(Bytes: TBytes): Variant;
+ public
+ class constructor Create;
+ // ڴתַ
+ class function MemStream2Str(MemStream: TMemoryStream): string; static;
+ // ַת
+ class procedure Str2MemStream(StrValue: string;
+ MemStream: TMemoryStream); static;
+
+ // json blob ת
+ class function JSONToStream(const Data: TQJson): TStream; static;
+ // json blob ת bytes
+ class function JSONToBytes(const Data: TQJson): TBytes; static;
+ // תjson
+ class function StreamToJSON(Stream: TStream; const Offset: Integer;
+ const ByteCount: Integer): TQJson; static;
+ // bytes תjson
+ class function BytesToJSON(const Bytes: TBytes; const Offset: Integer;
+ const ByteCount: Integer): TQJson; static;
+ // ݼתjson
+ class function DataSet2Json(DataSet: TDataSet;
+ const ShowMeata, ShowData, RowArray, StreamEncoded: Boolean;
+ const PageIndex, PageSize: Integer; const ArgsFields: Array of string;
+ const Included: Boolean): TQJson; static;
+ // תjson
+ class function DataSetRow2Json(DataSet: TDataSet;
+ const StreamEncoded: Boolean; JsonStream: TStringStream;
+ BlobStream: TMemoryStream; const ArgsFields: Array of string;
+ const Included: Boolean): TQJson; static;
+ // ¼ תjson
+ class function DataSetRow2JsonArray(DataSet: TDataSet;
+ const StreamEncoded: Boolean; JsonStream: TStringStream;
+ BlobStream: TMemoryStream; const ArgsFields: Array of string;
+ const Included: Boolean): TQJson; static; // array
+ // json תݼ
+ class function Json2DataSet(DataSet: TDataSet; const jsonStr: string;
+ DoDataSet: TProc): Integer; static;
+
+ // Уʽ
+ class function CheckJsonValue(const jsonValue, jsonFmt: string;
+ out Info: string): Boolean; static;
+ // Params תjson
+ class function Params2Json(Params: TParams;
+ const OnlyOutput, RowArray, StreamEncoded: Boolean): TQJson; static;
+ end;
+
+implementation
+
+uses System.StrUtils, Soap.EncdDecd, System.Math, System.DateUtils, System.Rtti;
+
+type
+ TJsonDBOpts = record
+ ShowMeata, ShowData, RowArray, StreamEncoded: Boolean;
+ end;
+
+function IncrAfter(var Arg: Integer): Integer;
+begin
+ Result := Arg;
+ Inc(Arg);
+end;
+
+class function TQDBJson.Bytes2Variant(Bytes: TBytes): Variant;
+var
+ p: pointer;
+begin
+ Result := VarArrayCreate([0, High(Bytes) - Low(Bytes)], varByte);
+ p := VarArrayLock(Result);
+ try
+ if Length(Bytes) > 0 then
+ Move(Bytes[0], p^, Length(Bytes));
+ finally
+ VarArrayUnlock(Result);
+ end;
+end;
+
+class function TQDBJson.BytesToJSON(const Bytes: TBytes;
+ const Offset, ByteCount: Integer): TQJson;
+var
+ i, NewByteCount: Integer;
+ Value: TValue;
+begin
+ Result := TQJson.Create;
+ if Length(Bytes) = 0 then
+ Exit();
+
+ Value := TValue.From(Bytes);
+ Result.FromRtti(Value);
+end;
+
+class function TQDBJson.CheckJsonValue(const jsonValue, jsonFmt: string;
+ out Info: string): Boolean;
+var
+ jsonUrlData, jsonFmtParam: TQJson;
+ jsonCheckItem: TQJson;
+begin
+ Result := True;
+ Info := '';
+
+ if not jsonValue.IsEmpty and not jsonFmt.IsEmpty then
+ begin
+ // URLݸʽ
+ jsonUrlData := TQJson.Create();
+ jsonFmtParam := TQJson.Create();
+ try
+ jsonUrlData.Parse(jsonValue);
+ //
+
+ jsonFmtParam.Parse(jsonFmt);
+
+ for jsonCheckItem in jsonFmtParam do
+ begin
+ if jsonUrlData.ItemByName(jsonCheckItem.Name) = nil then
+ begin
+ Info := Format('ָ json (%s)Ҳ', [jsonCheckItem.Name]);
+ Exit(False);
+ end
+ else
+ begin
+ // jsonUrlData.O[jsonCheckItem.Name].Self.DataType
+ case jsonUrlData.ItemByName(jsonCheckItem.Name).DataType of
+ // case jsonUrlData.Ancestor[jsonCheckItem.Name].DataType of
+ jdtNull: // ֵУ
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('NULL');
+ if not Result then
+ Info := Format('ָ json (%s)Ϊֵ(NULL)',
+ [jsonCheckItem.Name]);
+ end;
+ jdtBoolean: // У
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('BOOLEAN');
+ if not Result then
+ Info := Format('ָ json (%s)Ϊ(Boolean)',
+ [jsonCheckItem.Name]);
+ end;
+ jdtInteger: // У
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('INT');
+ if not Result then
+ Info := Format('ָ json (%s)Ϊ(Integer)',
+ [jsonCheckItem.Name]);
+ end;
+ jdtFloat: // У
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('DOUBLE') or
+ jsonCheckItem.AsString.ToUpper.Equals('FLOAT');
+ If not Result then
+ Info := Format('ָ json (%s)Ϊ(Double)',
+ [jsonCheckItem.Name]);
+ end;
+ jdtArray:
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('ARRAY');
+ If not Result then
+ Info := Format('ָ json (%s)Ϊ(Array)',
+ [jsonCheckItem.Name]);
+ end;
+ jdtDateTime:
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('DATETIME');
+ If not Result then
+ Info := Format('ָ json (%s)Ϊʱ(DATETIME)',
+ [jsonCheckItem.Name]);
+ end;
+ jdtString: // У ַ
+ begin
+ // ַп
+ // if CheckDate(jsonUrlData.S[jsonCheckItem.Name]) then
+ // begin
+ // Result := jsonCheckItem.AsString.ToUpper.Equals('DATETIME');
+ // If not Result then
+ // Info := Format('ָ json (%s)Ϊʱ(DateTime)',
+ // [jsonCheckItem.Name]);
+ // end
+ // else
+ if jsonUrlData.ItemByName(jsonCheckItem.Name)
+ .AsString.StartsWith('[blob]<') and
+ jsonUrlData.ItemByName(jsonCheckItem.Name)
+ .AsString.EndsWith('>') then
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('BLOB');
+ If not Result then
+ Info := Format('ָ json (%s)Ϊ BLOB (BLOB)',
+ [jsonCheckItem.Name]);
+ end
+ else
+ begin
+ Result := jsonCheckItem.AsString.ToUpper.Equals('STRING');
+ If not Result then
+ Info := Format('ָ json (%s)Ϊ ַ (STRING)',
+ [jsonCheckItem.Name]);
+ end;
+ end;
+ end;
+ end;
+ if not Result then
+ Break;
+ end; // end of for...
+ finally
+ jsonUrlData.Free;
+ jsonFmtParam.Free;
+ end;
+
+ end;
+end;
+
+class constructor TQDBJson.Create;
+begin
+ JsonCaseSensitive := False; // Сд
+end;
+
+class function TQDBJson.DataSet2Json(DataSet: TDataSet;
+ const ShowMeata, ShowData, RowArray, StreamEncoded: Boolean;
+ const PageIndex, PageSize: Integer; const ArgsFields: Array of string;
+ const Included: Boolean): TQJson;
+// Ԫݰ
+ function JsonValue4Field(Field: TField): TQJson;
+ begin
+ Result := TQJson.Create;
+ Result.DataType := jdtArray;
+
+ Result.Add.AsString := Field.FieldName;
+ Result.Add.AsInteger := Ord(Field.DataType);
+ Result.Add.AsInteger := Field.Size;
+ Result.Add.AsBoolean := Field.Required;
+ Result.Add.AsString := Field.DisplayLabel;
+ Result.Add.AsString := Field.ClassName;
+
+ end;
+
+var
+ Meta: TQJson;
+ Field: TField;
+ // BM: TBookmark;
+ JsonStream: TStringStream;
+ BlobStream: TMemoryStream;
+ MoveIndex, StepIndex: Integer;
+ Opts: TJsonDBOpts;
+begin
+ Result := TQJson.Create;
+
+ if not Assigned(DataSet) or not DataSet.Active then
+ Exit;
+
+ // Ԫ
+ if ShowMeata then
+ begin
+ Result.Add('meta').DataType := jdtArray;
+ Result.Add('field').DataType := jdtArray;
+
+ for Field in DataSet.Fields do
+ begin
+ Result.ItemByName('meta').Add(JsonValue4Field(Field));
+ Result.ItemByName('field').Add.AsString := Field.FieldName;
+ end;
+ end;
+ Result.Add('opts').DataType := jdtObject; // ѡ
+ Opts.ShowMeata := ShowMeata;
+ Opts.ShowData := ShowData;
+ Opts.RowArray := RowArray;
+ Opts.StreamEncoded := StreamEncoded;
+ Result.ItemByName('opts').FromRecord(Opts);
+
+ // raise Exception.Create(Result.AsJson);
+
+ JsonStream := TStringStream.Create();
+ BlobStream := TMemoryStream.Create;
+ // ӻ
+ DataSet.DisableControls;
+ try
+ // BM := DataSet.GetBookmark;
+ if ShowData then
+ begin
+ MoveIndex := 0;
+ Result.Add('data').DataType := jdtArray;
+ DataSet.First;
+ // ҳƶ¼
+ if (PageIndex > 0) and (PageSize > 0) then
+ begin
+ MoveIndex := (PageIndex - 1) * PageSize;
+ DataSet.MoveBy(MoveIndex);
+ end;
+ StepIndex := 0;
+ while not DataSet.Eof do
+ begin
+ // ǰ
+ if RowArray then
+ Result.ItemByName('data')
+ .Add(DataSetRow2JsonArray(DataSet, StreamEncoded, JsonStream,
+ BlobStream, ArgsFields, Included))
+ // Result.A['data'].Add(DataSetRow2JsonArray(DataSet, StreamEncoded,
+ // JsonStream, BlobStream, ArgsFields, Included))
+ else
+ Result.ItemByName('data').Add(DataSetRow2Json(DataSet, StreamEncoded,
+ JsonStream, BlobStream, ArgsFields, Included));
+ //
+ // Result.A['data'].Add(DataSetRow2Json(DataSet, StreamEncoded,
+ // JsonStream, BlobStream, ArgsFields, Included));
+
+ if (PageSize > 0) then
+ begin
+ Inc(StepIndex);
+ if StepIndex >= PageSize then
+ Break
+ else
+ begin
+ DataSet.Next;
+ Continue;
+ end;
+ end
+ else
+ DataSet.Next;
+ end;
+ end;
+ // DataSet.GotoBookmark(BM);
+ finally
+ JsonStream.Free;
+ BlobStream.Free;
+ // DataSet.FreeBookmark(BM);
+ DataSet.EnableControls;
+ end;
+end;
+
+class function TQDBJson.DataSetRow2Json(DataSet: TDataSet;
+ const StreamEncoded: Boolean; JsonStream: TStringStream;
+ BlobStream: TMemoryStream; const ArgsFields: Array of string;
+ const Included: Boolean): TQJson;
+
+// ж鷶Χ
+ function CheckArrayExists(const Args: array of string;
+ const CheckName: string; const Included: Boolean): Boolean;
+ var
+ argsSize: Integer;
+ begin
+ Result := False;
+ argsSize := Length(Args);
+ //
+ Result := (Included and ((argsSize = 0) or (IndexText(CheckName,
+ Args) <> -1))) or
+ //
+ (not Included and ((argsSize = 0) or (IndexText(CheckName, Args) = -1)));
+ end;
+
+var
+ Field: TField;
+ ja: TQJson;
+ JsonStreamCreated, BlobStreamCreated: Boolean;
+begin
+ // бΪģʽ
+ Result := TQJson.Create;
+ // Ƶ
+ JsonStreamCreated := False;
+ BlobStreamCreated := False;
+ if not Assigned(JsonStream) then
+ begin
+ JsonStream := TStringStream.Create();
+ JsonStreamCreated := True;
+ end;
+
+ if not Assigned(BlobStream) then
+ begin
+ BlobStream := TMemoryStream.Create;
+ BlobStreamCreated := True;
+ end;
+
+ try
+
+ for Field in DataSet.Fields do
+ begin
+ // жֶǷҪ
+ if not CheckArrayExists(ArgsFields, Field.FieldName, Included) then
+ Continue;
+
+ if Field.IsNull then
+ Result.Add(Field.FieldName, null, jdtNull)
+ else
+ begin
+ case Field.DataType of
+ ftBoolean:
+ Result.Add(Field.FieldName).AsBoolean := Field.AsBoolean;
+ ftDate, ftTime, ftDateTime, ftTimeStamp:
+ Result.Add(Field.FieldName).AsDateTime := Field.AsDateTime;
+ ftInteger, ftAutoInc, ftWord, ftSmallint, ftShortint:
+ Result.Add(Field.FieldName).AsInteger := Field.AsInteger;
+ ftLargeint:
+ Result.Add(Field.FieldName).AsInt64 := Field.AsLargeInt;
+ ftFloat, ftSingle, ftBCD, ftCurrency:
+ Result.Add(Field.FieldName).AsFloat := Field.AsFloat;
+ ftString, ftWideString, ftGuid:
+ Result.Add(Field.FieldName).AsString := Field.AsString;
+ ftBlob, ftGraphic, ftMemo, ftTypedBinary:
+ begin
+ if not StreamEncoded then
+ begin
+ Result.ItemByName(Field.FieldName)
+ .Add(BytesToJSON(TBlobField(Field).Value, 0, 0));
+ end
+ else // BASE64 ԽʡֽڴС
+ begin
+ JsonStream.Clear;
+ BlobStream.Clear;
+ TBlobField(Field).SaveToStream(BlobStream);
+ // JsonStream.Position :=0;
+ BlobStream.Position := 0;
+ EncodeStream(BlobStream, JsonStream);
+ Result.ItemByName(Field.FieldName).AsString := '[blob]<' +
+ JsonStream.DataString + '>';
+ JsonStream.Clear;
+ BlobStream.Clear;
+ end;
+ end;
+
+ else
+ Result.Add(Field.FieldName).AsString := Field.AsString;
+ end;
+ end;
+ end;
+ finally
+ if Assigned(JsonStream) and JsonStreamCreated then
+ JsonStream.Free;
+
+ if Assigned(BlobStream) and BlobStreamCreated then
+ BlobStream.Free;
+ end;
+end;
+
+class function TQDBJson.DataSetRow2JsonArray(DataSet: TDataSet;
+ const StreamEncoded: Boolean; JsonStream: TStringStream;
+ BlobStream: TMemoryStream; const ArgsFields: array of string;
+ const Included: Boolean): TQJson;
+// ж鷶Χ
+ function CheckArrayExists(const Args: array of string;
+ const CheckName: string; const Included: Boolean): Boolean;
+ var
+ argsSize: Integer;
+ begin
+ Result := False;
+ argsSize := Length(Args);
+ //
+ Result := (Included and ((argsSize = 0) or (IndexText(CheckName,
+ Args) <> -1))) or
+ //
+ (not Included and ((argsSize = 0) or (IndexText(CheckName, Args) = -1)));
+ end;
+
+var
+ Field: TField;
+ JsonStreamCreated, BlobStreamCreated: Boolean;
+begin
+ // бΪģʽ
+ Result := TQJson.Create;
+ Result.DataType := jdtArray;
+ // Ƶ
+ JsonStreamCreated := False;
+ BlobStreamCreated := False;
+ if not Assigned(JsonStream) then
+ begin
+ JsonStream := TStringStream.Create();
+ JsonStreamCreated := True;
+ end;
+
+ if not Assigned(BlobStream) then
+ begin
+ BlobStream := TMemoryStream.Create;
+ BlobStreamCreated := True;
+ end;
+
+ try
+ for Field in DataSet.Fields do
+ begin
+ // жֶǷҪ
+ if not CheckArrayExists(ArgsFields, Field.FieldName, Included) then
+ Continue;
+
+ if Field.IsNull then
+ Result.Add(null)
+ else
+ begin
+ case Field.DataType of
+ ftBoolean:
+ Result.Add.AsBoolean := Field.AsBoolean;
+ ftDate, ftTime, ftDateTime, ftTimeStamp, ftTimeStampOffset:
+ Result.Add.AsDateTime := Field.AsDateTime;
+ ftInteger, ftAutoInc, ftWord, ftSmallint, ftShortint:
+ Result.Add.AsInteger := Field.AsInteger;
+ ftLargeint:
+ Result.Add.AsInt64 := Field.AsLargeInt;
+ ftFloat, ftSingle, ftBCD:
+ Result.Add.AsFloat := Field.AsFloat;
+ ftCurrency:
+ Result.Add.AsFloat := Field.AsCurrency;
+ ftString, ftWideString, ftGuid:
+ Result.Add.AsString := Field.AsString;
+ ftBlob, ftGraphic, ftMemo, ftTypedBinary:
+ begin
+ if not StreamEncoded then
+ begin
+ Result.Add(BytesToJSON(TBlobField(Field).Value, 0, 0));
+ end
+ else // BASE64 ԽʡֽڴС
+ begin
+ JsonStream.Clear;
+ BlobStream.Clear;
+ TBlobField(Field).SaveToStream(BlobStream);
+ // JsonStream.Position :=0;
+ BlobStream.Position := 0;
+ EncodeStream(BlobStream, JsonStream);
+ Result.Add.AsString := '[blob]<' + JsonStream.DataString + '>';
+ JsonStream.Clear;
+ BlobStream.Clear;
+ end;
+ end;
+
+ else
+ Result.Add(Field.AsString);
+ end;
+ end;
+ end;
+ finally
+ if Assigned(JsonStream) and JsonStreamCreated then
+ JsonStream.Free;
+
+ if Assigned(BlobStream) and BlobStreamCreated then
+ BlobStream.Free;
+ end;
+end;
+
+class function TQDBJson.ISOStr2DateTime(DateStr: string): TDateTime;
+var
+ y, m, D, hh, mm, ss, ms: Word;
+ s2: string;
+ A: Integer;
+ function GetNum(const sep: string): Word;
+ begin
+ if DateStr = '' then
+ Result := 0
+ else if sep = '' then
+ begin
+ Result := StrToInt(DateStr);
+ DateStr := '';
+ end
+ else
+ begin
+ A := Pos(sep, DateStr);
+ if A <= 0 then
+ A := Length(DateStr) + 1;
+ try
+ Result := StrToInt(Copy(DateStr, 1, A - 1));
+ except
+ raise EConvertError.Create('Invalid DateTime format.');
+ end;
+ Delete(DateStr, 1, A);
+ DateStr := Trim(DateStr);
+ end;
+ end;
+
+begin
+ try
+ Result := 0;
+ A := Pos('T', DateStr);
+ if (A > 0) or (Pos(':', DateStr) < Low(DateStr)) then
+ // date included or time not included
+ begin
+ if Pos('-', DateStr) > 0 then
+ begin
+ y := GetNum('-');
+ m := GetNum('-');
+ D := GetNum('T');
+ end
+ else
+ begin
+ if A > 0 then
+ begin
+ s2 := Copy(DateStr, 1, A - 1);
+ Delete(DateStr, 1, A);
+ end
+ else
+ begin
+ s2 := DateStr;
+ DateStr := '';
+ end;
+ if Length(s2) >= 4 then
+ begin
+ y := StrToInt(Copy(s2, 1, 4));
+ Delete(s2, 1, 4);
+ end
+ else
+ y := 0;
+ if Length(s2) >= 2 then
+ begin
+ m := StrToInt(Copy(s2, 1, 2));
+ Delete(s2, 1, 2);
+ end
+ else
+ m := 0;
+ if Length(s2) >= 2 then
+ begin
+ D := StrToInt(Copy(s2, 1, 2));
+ Delete(s2, 1, 2);
+ end
+ else
+ D := 0;
+ end;
+
+ if (y > 0) or (m > 0) or (D > 0) then
+ Result := EncodeDate(y, m, D);
+
+ if Length(s2) > 0 then
+ raise EConvertError.Create('Date Part too long.');
+ end;
+
+ if Length(DateStr) > 0 then // time included
+ begin
+ hh := GetNum(':');
+ mm := GetNum(':');
+ ss := GetNum('.');
+ ms := GetNum('+');
+ if (hh > 0) or (mm > 0) or (ss > 0) or (ms > 0) then
+ if Result >= 0 then
+ Result := Result + EncodeTime(hh, mm, ss, ms)
+ else
+ Result := Result - EncodeTime(hh, mm, ss, ms);
+ end;
+ except
+ on E: Exception do
+ raise EConvertError.Create(E.Message + #13#10'Invalid DateTime format.');
+ end;
+end;
+
+class function TQDBJson.Json2DataSet(DataSet: TDataSet;
+ const jsonStr: string; DoDataSet: TProc): Integer;
+
+ function JsonValue2Var(json: TQJson;
+ JsonStream, BlobStream: TMemoryStream): Variant;
+ var
+ dt: TDateTime;
+ JsonStreamCreated, BlobStreamCreated: Boolean;
+ jsonBlobStr: string;
+ Args: TBytes;
+ begin
+ Result := null;
+ case json.DataType of
+ jdtNull:
+ Result := null;
+ jdtBoolean:
+ Result := json.AsBoolean;
+ jdtInteger:
+ Result := json.AsInteger;
+ jdtFloat:
+ Result := json.AsFloat;
+ jdtDateTime:
+ Result := json.AsDateTime;
+ jdtString:
+ begin
+ if json.AsString.StartsWith('[blob]<') And json.AsString.EndsWith('>')
+ then
+ begin
+ // Ƶ
+ try
+ JsonStreamCreated := False;
+ BlobStreamCreated := False;
+ if not Assigned(JsonStream) then // п base64
+ begin
+ JsonStream := TStringStream.Create();
+ JsonStreamCreated := True;
+ end;
+
+ if not Assigned(BlobStream) then
+ begin
+ BlobStream := TMemoryStream.Create;
+ BlobStreamCreated := True;
+ end;
+ JsonStream.Clear;
+ BlobStream.Clear;
+ // ȥͷβ
+ jsonBlobStr := json.AsString.Substring(7,
+ json.AsString.Length - 8);
+ JsonStream.Write(jsonBlobStr[Low(jsonBlobStr)],
+ Length(jsonBlobStr) * SizeOf(Char));
+ JsonStream.Position := 0;
+
+ DecodeStream(JsonStream, BlobStream);
+ BlobStream.Position := 0;
+
+ SetLength(Args, BlobStream.Size);
+ BlobStream.ReadBuffer(Args, 0, BlobStream.Size);
+ Result := Args;
+ finally
+ if Assigned(JsonStream) and JsonStreamCreated then
+ JsonStream.Free;
+
+ if Assigned(BlobStream) and BlobStreamCreated then
+ BlobStream.Free;
+ end;
+ end
+ else
+ Result := json.AsString;
+ end;
+ jdtArray:
+ begin
+ // Result := TJsonHelper.JSONToBytes(json.AsArray)
+ Result := TQDBJson.JSONToBytes(json)
+ end;
+ end;
+ end;
+
+var
+ i: Integer;
+ json, FieldData: TQJson;
+ Meta, Data: TQJson; //
+ Item, json2: TQJson;
+ Field: TField;
+ JsonStream, BlobStream: TMemoryStream;
+ FldName: string;
+ Opts: TJsonDBOpts;
+begin
+ Result := -1;
+ if jsonStr.Trim.IsEmpty then
+ Exit;
+
+ JsonStream := TMemoryStream.Create;
+ BlobStream := TMemoryStream.Create;
+ try
+ DataSet.DisableControls;
+ DataSet.Close;
+ DataSet.FieldDefs.Clear;
+
+ json := TQJson.Create;
+ json.Parse(jsonStr.Trim);
+ // or (json.N['meta'].DataType = stNull)
+ if (json.ItemByName('meta') = nil) or
+ (json.ItemByName('meta').DataType <> jdtArray) then
+ Exit;
+
+ try
+ Meta := json.ItemByName('meta');
+ if not Assigned(Meta) or (Meta.DataType<>jdtArray) then
+ raise Exception.Create('ֶԪϢΪջJsonͣ');
+
+ for json2 in Meta do
+ begin
+ //json2.Items[0].AsString
+ DataSet.FieldDefs.Add(json2.Items[0].AsString,
+ TFieldType(json2.Items[1].AsInteger), json2.Items[2].AsInteger,
+ json2.Items[3].AsBoolean);
+ end;
+ // DataSet.FieldDefs.Update;
+
+ if Assigned(DoDataSet) then
+ DoDataSet;
+
+ if not DataSet.Active then
+ DataSet.Open;
+
+ Meta := json.ItemByName('field');
+
+ Data := json.ItemByName('data');
+ if json.ItemByName('opts') <> nil then
+ json.ItemByName('opts').ToRtti(@Opts, TypeInfo(TJsonDBOpts));
+
+ if not Assigned(Data) or (Data.DataType <> jdtArray) then
+ Exit;
+
+ // Data ѭݣһ
+ for json2 in Data do
+ begin
+ FldName := '';
+ // ģʽ
+ if json2.DataType = jdtArray then
+ begin
+ DataSet.Append;
+ i := 0;
+ for Item in json2 do
+ begin
+ FldName := DataSet.Fields[i].FieldName;
+ DataSet.Fields[i].Value := JsonValue2Var(Item, JsonStream,
+ BlobStream);
+ Inc(i);
+ end;
+ DataSet.Post;
+ end // ģʽ
+ else if json2.DataType = jdtObject then
+ begin
+ for Item in json2 do
+ begin
+ if DataSet.FindField(Item.Name) = nil then
+ Continue;
+ FldName := Item.Name;
+ DataSet.FieldByName(Item.Name).Value :=
+ JsonValue2Var(Item, JsonStream, BlobStream);
+ end;
+ end;
+ end;
+ except
+ raise Exception.CreateFmt('jsonֶ(%s)ֵݼ쳣', [FldName]);
+ end;
+
+ finally
+ JsonStream.Free;
+ BlobStream.Free;
+ if DataSet.Active then
+ DataSet.First;
+
+ json.Free;
+ DataSet.EnableControls;
+ end;
+end;
+
+class function TQDBJson.JSONToBytes(const Data: TQJson): TBytes;
+var
+ i: Integer;
+ ByteVal: Integer;
+ Member: TQJson;
+ // Value:TValue;
+begin
+ SetLength(Result, 0);
+ if not Assigned(Data) or (Data.DataType <> jdtArray) then
+ Exit;
+ SetLength(Result, Data.Count);
+ // Value := Data.ToRttiValue;
+ // if not Value.IsEmpty then
+ // Result := Value.AsType;
+ i := 0;
+ for Member in Data do
+ begin
+ if (Member.DataType = jdtInteger) and (Member.AsInteger >= 0) and
+ (Member.AsInteger <= 255) then
+ begin
+ ByteVal := Member.AsInteger;
+ Result[i] := Byte(ByteVal);
+ end
+ else
+ Result[i] := 0;
+
+ Inc(i);
+ // raise Exception.Create('Cannot convert JSON input into a stream');
+ end;
+end;
+
+class function TQDBJson.JSONToStream(const Data: TQJson): TStream;
+var
+ Bytes: TArray;
+begin
+ Result := nil;
+ if Assigned(Data) and (Data.DataType = jdtArray) then
+ begin
+ // TSuperArray.Create(jo.Self as TJSONArray);
+ Bytes := JSONToBytes(Data);
+ Result := TBytesStream.Create(Bytes);
+ end;
+end;
+
+class function TQDBJson.MemStream2Str(MemStream: TMemoryStream): string;
+var
+ StrSteam: TStringStream;
+begin
+ StrSteam := TStringStream.Create('', TEncoding.UTF8);
+ try
+ MemStream.SaveToStream(StrSteam);
+ Result := StrSteam.DataString;
+ // result := EncodeString(StrSteam.DataString);
+ finally
+ StrSteam.Free;
+ end;
+end;
+
+class function TQDBJson.Params2Json(Params: TParams;
+ const OnlyOutput, RowArray, StreamEncoded: Boolean): TQJson;
+
+ procedure Var2Json(json: TQJson; const KeyName: string; const Value: Variant);
+ var
+ Dynarray: TArray;
+ Vaue: TValue;
+ begin
+ if not Assigned(json) then
+ Exit;
+
+ if json.DataType = jdtArray then
+ begin
+ case VarType(Value) of
+ varEmpty, varNull:
+ json.Add(null);
+ varBoolean:
+ json.Add.AsBoolean := Boolean(Value);
+ varDate:
+ json.Add.AsDateTime := VarToDateTime(Value);
+ varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord,
+ varInt64, varUInt64:
+ json.Add.AsInt64 := Value;
+ varSingle, varDouble, varCurrency:
+ json.Add.AsFloat := Value;
+ varOleStr, varString, varUString:
+ json.Add.AsString := Value;
+ (varByte or varArray):
+ begin Vaue :=
+ TValue.From(Variant2Bytes(Value));
+ json.Add.FromRtti(Vaue);
+ end;
+ end;
+ end
+ else if json.DataType = jdtObject then
+ begin
+ case VarType(Value)of
+ varEmpty, varNull:
+ json.Add(KeyName).AsVariant := null;
+ varBoolean:
+ json.Add(KeyName).AsBoolean := Boolean(Value);
+ varDate:
+ json.Add(KeyName).AsDateTime := Value;
+ // FormatDateTime('yyyy-MM-dd', VarToDateTime(Value));
+ varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord,
+ varInt64, varUInt64:
+ json.Add(KeyName).AsInt64 := Value;
+ varSingle, varDouble, varCurrency:
+ json.Add(KeyName).AsFloat := Value;
+ varOleStr, varString, varUString:
+ json.Add(KeyName).AsString := Value;
+ (varByte or varArray):
+ begin
+ Vaue :=
+ TValue.From(Variant2Bytes(Value));
+ json.Add(KeyName).FromRtti(Vaue);
+ end;
+ end;
+ end;
+ end;
+
+ var
+ i:Integer;
+ begin
+ Result := TQJson.Create();
+ for i := 0 to Params.Count - 1 do
+ begin
+ if RowArray then
+ begin
+ if OnlyOutput then
+ begin
+ if (Params[i].ParamType in [ptOutput, ptInputOutput]) then
+ Var2Json(Result, Params[i].Name, Params[i].Value)
+ end
+ else
+ Var2Json(Result, Params[i].Name, Params[i].Value)
+ end
+ else
+ begin
+ if OnlyOutput then
+ begin
+ if (Params[i].ParamType in [ptOutput, ptInputOutput]) then
+ Var2Json(Result, Params[i].Name, Params[i].Value)
+ end
+ else
+ Var2Json(Result, Params[i].Name, Params[i].Value)
+ end;
+ end;
+ end;
+
+class procedure TQDBJson.Str2MemStream(StrValue: string;
+ MemStream: TMemoryStream);
+var
+ StrSteam: TStringStream;
+begin
+ StrSteam := TStringStream.Create(StrValue, TEncoding.UTF8);
+ try
+ // StrValue := DecodeString(StrValue);
+ // StrSteam.Read(StrValue, length(StrValue));
+ MemStream.LoadFromStream(StrSteam);
+ MemStream.Position := 0;
+ finally
+ StrSteam.Free;
+ end;
+end;
+
+class function TQDBJson.StreamToJSON(Stream: TStream;
+ const Offset, ByteCount: Integer): TQJson;
+var
+ ja: TQJson;
+ Bytes: TBytes;
+begin
+ Result := nil;
+
+ if Stream = nil then
+ Exit(ja);
+ Stream.Position := 0;
+ SetLength(Bytes, Stream.Size);
+ Stream.ReadBuffer(Bytes, Stream.Size);
+ Result := BytesToJSON(Bytes, Offset, ByteCount)
+end;
+
+class function TQDBJson.Variant2Bytes(V: Variant): TBytes;
+var
+ p: pointer;
+ Size: Int64;
+begin
+ Size := VarArrayHighBound(V, 1) - VarArrayLowBound(V, 1) + 1;
+ SetLength(Result, Size);
+ p := VarArrayLock(V);
+ try
+ Move(p^, Result[0], Size);
+ finally
+ VarArrayUnlock(V);
+ end;
+end;
+
+end.
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.dpr" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.dpr"
new file mode 100644
index 0000000..58e4d3f
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.dpr"
@@ -0,0 +1,16 @@
+program JSON_Test;
+
+uses
+ Forms,
+ Unit2 in 'Unit2.pas' {Form2},
+ uLkJSON in 'uLkJSON.pas';
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm2, Form2);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.dproj" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.dproj"
new file mode 100644
index 0000000..a049b1b
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.dproj"
@@ -0,0 +1,76 @@
+
+
+ {d1bcadc3-e5a0-46c3-8d93-203fd8ced567}
+ JSONTest.dpr
+ Debug
+ AnyCPU
+ DCC32
+ JSONTest.exe
+
+
+ 7.0
+ False
+ False
+ 0
+ RELEASE
+
+
+ 7.0
+ DEBUG
+ ..\..\..\qdac;..\..\..\source
+ ..\..\..\qdac;..\..\..\source
+ ..\..\..\qdac;..\..\..\source
+ ..\..\..\qdac;..\..\..\source
+
+
+ Delphi.Personality
+ VCLApplication
+
+
+ False
+ True
+ False
+
+
+ True
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 1033
+ 1252
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+ JSONTest.dpr
+
+
+
+
+
+
+ MainSource
+
+
+
+
+
+
+
\ No newline at end of file
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.otares" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.otares"
new file mode 100644
index 0000000..93e7e94
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.otares" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.res" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.res"
new file mode 100644
index 0000000..70d86d0
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest.res" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_Icon2.ico" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_Icon2.ico"
new file mode 100644
index 0000000..9917d72
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_Icon2.ico" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.dpr" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.dpr"
new file mode 100644
index 0000000..d79448e
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.dpr"
@@ -0,0 +1,17 @@
+program JSONTest_XE;
+
+uses
+ Forms,
+ Unit2 in 'Unit2.pas' {Form2},
+ uLkJSON in 'uLkJSON.pas',
+ QString in 'QString.pas';
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm2, Form2);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.dproj" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.dproj"
new file mode 100644
index 0000000..a699d6c
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.dproj"
@@ -0,0 +1,213 @@
+
+
+ {2778da2e-1090-4b05-b789-1366e08ab8a3}
+ Debug
+ DCC32
+ bin\JSONTest.exe
+ JSONTest_XE.dpr
+ True
+ Debug
+ 3
+ Application
+ VCL
+ 15.4
+ Win64
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_1
+ true
+ true
+
+
+ true
+ Cfg_1
+ true
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_2
+ true
+ true
+
+
+ true
+ Cfg_2
+ true
+ true
+
+
+ JSONTest_Icon2.ico
+ $(BDS)\bin\default_app.manifest
+ JSONTest_XE
+ Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)
+ 2052
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
+
+
+ System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
+ true
+ 1033
+
+
+ 1033
+ System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)
+ true
+
+
+ 7.0
+ 0
+ False
+ 0
+ RELEASE;$(DCC_Define)
+
+
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ true
+ ..\..\..\dcu
+ ..\..\..\dcu
+ true
+ ..\..\..\bin
+ 1033
+ ..\..\..\bin
+
+
+ ..\..\..\bin
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\
+ true
+ 1033
+
+
+ 7.0
+ DEBUG;$(DCC_Define)
+ .\bin
+ .\dcu
+ .\dcu
+ .\dcu
+ .\bin
+ .\dcu
+
+
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ ..\..\..\bin
+ ..\..\..\bin
+ true
+ ..\..\..\dcu
+ 1033
+ ..\..\..\dcu
+
+
+ ..\..\..\bin
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ true
+ 1033
+
+
+ Delphi.Personality.12
+
+
+
+
+ False
+ True
+ False
+
+
+ False
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 2052
+ 936
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+ JSONTest_XE.dpr
+
+
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+ Embarcadero C++Builder Office 2000 Servers Package
+ Embarcadero C++Builder Office XP Servers Package
+
+
+
+ True
+ True
+
+
+ 12
+
+
+
+
+ MainSource
+
+
+
+
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+
+
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.res" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.res"
new file mode 100644
index 0000000..b60aad9
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_XE.res" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.dpr" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.dpr"
new file mode 100644
index 0000000..c0bafad
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.dpr"
@@ -0,0 +1,17 @@
+program JSONTest;
+
+uses
+ Forms,
+ Unit2 in 'Unit2.pas' {Form2},
+ uJSON in 'uJSON.pas',
+ uLkJSON in 'uLkJSON.pas';
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm2, Form2);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.dproj" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.dproj"
new file mode 100644
index 0000000..1f7ef53
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.dproj"
@@ -0,0 +1,77 @@
+
+
+ {ace080c6-4d89-4142-a42b-c8ed2b60798c}
+ JSONTest_d2007.dpr
+ Debug
+ AnyCPU
+ DCC32
+ ..\..\..\bin\JSONTest_d2007.exe
+
+
+ 7.0
+ False
+ False
+ 0
+ RELEASE
+
+
+ 7.0
+ DEBUG
+ ..\..\..\qdac;..\..\..\source;
+ ..\..\..\qdac;..\..\..\source;
+ ..\..\..\qdac;..\..\..\source;
+ ..\..\..\qdac;..\..\..\source;
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\dcu
+
+
+ Delphi.Personality
+ VCLApplication
+
+FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse20529361.0.0.01.0.0.0
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ CodeGear C++Builder Office 2000 Servers Package
+ CodeGear C++Builder Office XP Servers Package
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+ JSONTest_d2007.dpr
+
+
+
+
+ MainSource
+
+
+
+
+
+
+
+
\ No newline at end of file
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.res" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.res"
new file mode 100644
index 0000000..4f415bd
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007.res" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007_Icon.ico" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007_Icon.ico"
new file mode 100644
index 0000000..2bc1f2c
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSONTest_d2007_Icon.ico" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test.dproj" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test.dproj"
new file mode 100644
index 0000000..c1146d8
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test.dproj"
@@ -0,0 +1,165 @@
+
+
+ {2778da2e-1090-4b05-b789-1366e08ab8a3}
+ Debug
+ DCC32
+ ..\..\..\bin\JSONTest.exe
+ JSONTest.dpr
+ True
+ Debug
+ 1
+ Application
+ VCL
+ 15.4
+ Win32
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ JSON_Test
+ Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)
+ 1033
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
+ true
+
+
+ $(BDS)\bin\default_app.manifest
+ Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
+ JSON_Test_Icon.ico
+ true
+ 1033
+
+
+ $(BDS)\bin\default_app.manifest
+ JSON_Test_Icon.ico
+
+
+ 7.0
+ 0
+ False
+ 0
+ RELEASE;$(DCC_Define)
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_ResourcePath)
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_ObjPath)
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_IncludePath)
+
+
+ 7.0
+ DEBUG;$(DCC_Define)
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_ResourcePath)
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_ObjPath)
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_IncludePath)
+
+
+ Delphi.Personality.12
+
+
+
+
+ False
+ True
+ False
+
+
+ True
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 1033
+ 1252
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+ JSONTest.dpr
+
+
+ CodeGear C++Builder Office 2000 Servers Package
+ CodeGear C++Builder Office XP Servers Package
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+
+
+
+ True
+ False
+
+
+ 12
+
+
+
+
+ MainSource
+
+
+
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+
+
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test.res" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test.res"
new file mode 100644
index 0000000..6892d28
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test.res" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test_Icon.ico" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test_Icon.ico"
new file mode 100644
index 0000000..2bc1f2c
Binary files /dev/null and "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/JSON_Test_Icon.ico" differ
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/Unit2.dfm" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/Unit2.dfm"
new file mode 100644
index 0000000..4be071c
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/Unit2.dfm"
@@ -0,0 +1,275 @@
+object Form2: TForm2
+ Left = 0
+ Top = 0
+ Caption = 'JSON '#24615#33021#27979#35797
+ ClientHeight = 508
+ ClientWidth = 939
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Tahoma'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCreate = FormCreate
+ DesignSize = (
+ 939
+ 508)
+ PixelsPerInch = 96
+ TextHeight = 13
+ object YxdPageControl1: TPageControl
+ Left = 8
+ Top = 208
+ Width = 923
+ Height = 292
+ ActivePage = TabSheet1
+ Anchors = [akLeft, akTop, akRight, akBottom]
+ TabOrder = 0
+ object TabSheet1: TTabSheet
+ Caption = #28304'JSON'#25968#25454
+ object Memo1: TMemo
+ AlignWithMargins = True
+ Left = 3
+ Top = 3
+ Width = 909
+ Height = 258
+ Align = alClient
+ Lines.Strings = (
+ '{'
+ #9'"error": 0,'
+ #9'"status": "success",'
+ #9'"currentCity": "'#21271#20140'",'
+ #9'"dateTime": "2014/07/12/11/29/38",'
+ '"items": [1,2,3,4,5,6,7,8,9,[123,456,789]],'
+ #9'"results": ['
+ #9#9'{'
+ #9#9#9'"startTime": "2014/02/26/00/00/00",'
+ #9#9#9'"title": "'#20986#21475#21277#36947#38480#21046'('#38271#26399')",'
+
+ #9#9#9'"description": "2014'#24180'2'#26376'26'#26085#36215#65292#27599#22825'7'#26102#33267'15'#26102#65292#21271#20845#29615#22806#29615#65292#20140#34255#39640#36895#20844#36335#20986#21475#21277#36947#65292#31105#27490#36733#36135#27773#36710#36890 +
+ #34892#12290'",'
+ #9#9#9'"location": {'
+ #9#9#9#9'"lng": 116.2499668836,'
+ #9#9#9#9'"lat": 40.172181392632'
+ #9#9#9'},'
+ #9#9#9'"type": "3"'
+ #9#9'},'
+ #9#9'{'
+ #9#9#9'"title": "'#21271#19977#29615#35199#36335#36947#36335#26045#24037'",'
+
+ #9#9#9'"description": "'#20174'7'#26376'3'#26085#21040'8'#26376'28'#26085#65292#33487#24030#26725#65292#22806#29615#26041#21521#65292#36827#34892#22823#20462#26045#24037#65292#26045#24037#26102#38388#20026#27599#22825#26202#38388'23'#26102'30'#20998#33267#20940 +
+ #26216'5'#26102'30'#20998#65292#30333#22825#27491#24120#25918#34892#31038#20250#20132#36890'",'
+ #9#9#9'"location": {'
+ #9#9#9#9'"lng": 116.31302490979,'
+ #9#9#9#9'"lat": 39.964084503915'
+ #9#9#9'},'
+ #9#9#9'"type": "2"'
+ #9#9'}'
+ #9']'
+ '}')
+ ScrollBars = ssBoth
+ TabOrder = 0
+ end
+ object CheckBox1: TCheckBox
+ Left = 712
+ Top = -48
+ Width = 97
+ Height = 17
+ Caption = 'CheckBox1'
+ TabOrder = 1
+ end
+ end
+ object TabSheet2: TTabSheet
+ Caption = #36755#20986#32467#26524
+ ExplicitLeft = 0
+ ExplicitTop = 0
+ ExplicitWidth = 0
+ ExplicitHeight = 0
+ object Memo2: TMemo
+ AlignWithMargins = True
+ Left = 3
+ Top = 3
+ Width = 909
+ Height = 258
+ Align = alClient
+ ReadOnly = True
+ ScrollBars = ssBoth
+ TabOrder = 0
+ end
+ end
+ object TabSheet3: TTabSheet
+ Caption = #26085#24535
+ ExplicitLeft = 0
+ ExplicitTop = 0
+ ExplicitWidth = 0
+ ExplicitHeight = 0
+ object ListBox1: TListBox
+ AlignWithMargins = True
+ Left = 3
+ Top = 3
+ Width = 909
+ Height = 258
+ Align = alClient
+ ItemHeight = 13
+ PopupMenu = PopupMenu1
+ TabOrder = 0
+ end
+ end
+ end
+ object Button1: TButton
+ Left = 8
+ Top = 8
+ Width = 161
+ Height = 25
+ Caption = #35835#21462#28304'JSON, toString(0)'
+ TabOrder = 1
+ OnClick = Button1Click
+ end
+ object Button2: TButton
+ Left = 8
+ Top = 70
+ Width = 161
+ Height = 25
+ Caption = #35835#21462#28304'JSON'#25968#25454'20000'#27425
+ TabOrder = 2
+ OnClick = Button2Click
+ end
+ object Button3: TButton
+ Left = 8
+ Top = 39
+ Width = 161
+ Height = 25
+ Caption = #35835#21462#28304'JSON, toString(4)'
+ TabOrder = 3
+ OnClick = Button3Click
+ end
+ object Button4: TButton
+ Left = 8
+ Top = 101
+ Width = 161
+ Height = 25
+ Caption = #28155#21152#21024#38500#24615#33021#27979#35797
+ TabOrder = 4
+ OnClick = Button4Click
+ end
+ object Button5: TButton
+ Left = 175
+ Top = 70
+ Width = 171
+ Height = 25
+ Caption = 'QJson'#35835#21462#28304'JSON, toString'
+ TabOrder = 5
+ OnClick = Button5Click
+ end
+ object Button6: TButton
+ Left = 8
+ Top = 132
+ Width = 161
+ Height = 25
+ Caption = #21152#36733'test.json'
+ TabOrder = 6
+ OnClick = Button6Click
+ end
+ object Button7: TButton
+ Left = 8
+ Top = 163
+ Width = 161
+ Height = 25
+ Caption = 'QJson'#21152#36733'test.json'
+ TabOrder = 7
+ OnClick = Button7Click
+ end
+ object Button8: TButton
+ Left = 175
+ Top = 8
+ Width = 171
+ Height = 25
+ Caption = 'yxdjson'#21152#36733'Preferences.txt'
+ TabOrder = 8
+ OnClick = Button8Click
+ end
+ object Button9: TButton
+ Left = 175
+ Top = 39
+ Width = 171
+ Height = 25
+ Caption = 'qjson'#21152#36733'Preferences.txt'
+ TabOrder = 9
+ OnClick = Button9Click
+ end
+ object CheckBox2: TCheckBox
+ Left = 262
+ Top = 209
+ Width = 179
+ Height = 17
+ Caption = #21152#36733#23436#25104#21518#26174#31034#21040#36755#20986#32467#26524
+ TabOrder = 10
+ end
+ object Button10: TButton
+ Left = 175
+ Top = 101
+ Width = 171
+ Height = 25
+ Caption = 'parseStringByName'
+ TabOrder = 11
+ OnClick = Button10Click
+ end
+ object Button11: TButton
+ Left = 175
+ Top = 132
+ Width = 171
+ Height = 25
+ Caption = #21152#36733#25351#23450' json '#25991#20214
+ TabOrder = 12
+ OnClick = Button11Click
+ end
+ object Button12: TButton
+ Left = 352
+ Top = 70
+ Width = 177
+ Height = 25
+ Caption = 'ItemByPath'
+ TabOrder = 13
+ OnClick = Button12Click
+ end
+ object Button16: TButton
+ Left = 352
+ Top = 8
+ Width = 177
+ Height = 25
+ Caption = 'ParseObjectByName'
+ TabOrder = 14
+ OnClick = Button16Click
+ end
+ object Button17: TButton
+ Left = 352
+ Top = 39
+ Width = 177
+ Height = 25
+ Caption = 'AddChildObject'
+ TabOrder = 15
+ OnClick = Button17Click
+ end
+ object Button18: TButton
+ Left = 175
+ Top = 163
+ Width = 171
+ Height = 25
+ Caption = 'SuperJson'#29992#27861#27979#35797
+ TabOrder = 16
+ OnClick = Button18Click
+ end
+ object PopupMenu1: TPopupMenu
+ Left = 520
+ Top = 328
+ object N1: TMenuItem
+ Caption = #28165#31354
+ OnClick = N1Click
+ end
+ end
+ object OpenDialog1: TOpenDialog
+ Filter = '*.json|*.json;*.txt|*.*|*.*'
+ Left = 432
+ Top = 128
+ end
+end
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/Unit2.pas" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/Unit2.pas"
new file mode 100644
index 0000000..8ef61c2
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/Unit2.pas"
@@ -0,0 +1,426 @@
+unit Unit2;
+
+interface
+
+{$WARNINGS OFF}
+
+uses
+ YxdStr,
+ Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, Menus,
+ {$IF (RTLVersion>=26)}Vcl.ComCtrls{$ELSE}ComCtrls{$IFEND};
+
+type
+ TForm2 = class(TForm)
+ YxdPageControl1: TPageControl;
+ TabSheet1: TTabSheet;
+ Memo1: TMemo;
+ TabSheet2: TTabSheet;
+ Memo2: TMemo;
+ TabSheet3: TTabSheet;
+ ListBox1: TListBox;
+ Button1: TButton;
+ Button2: TButton;
+ Button3: TButton;
+ PopupMenu1: TPopupMenu;
+ N1: TMenuItem;
+ Button4: TButton;
+ Button5: TButton;
+ Button6: TButton;
+ Button7: TButton;
+ Button8: TButton;
+ Button9: TButton;
+ CheckBox1: TCheckBox;
+ CheckBox2: TCheckBox;
+ Button10: TButton;
+ Button11: TButton;
+ OpenDialog1: TOpenDialog;
+ Button12: TButton;
+ Button16: TButton;
+ Button17: TButton;
+ Button18: TButton;
+ procedure Button1Click(Sender: TObject);
+ procedure Button3Click(Sender: TObject);
+ procedure Button2Click(Sender: TObject);
+ procedure N1Click(Sender: TObject);
+ procedure Button4Click(Sender: TObject);
+ procedure Button5Click(Sender: TObject);
+ procedure Button6Click(Sender: TObject);
+ procedure Button7Click(Sender: TObject);
+ procedure Button8Click(Sender: TObject);
+ procedure Button9Click(Sender: TObject);
+ procedure Button10Click(Sender: TObject);
+ procedure Button11Click(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure Button12Click(Sender: TObject);
+ procedure Button16Click(Sender: TObject);
+ procedure Button17Click(Sender: TObject);
+ procedure Button18Click(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ Form2: TForm2;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ YxdJson, qjson, uLkJSON, QString;
+
+const
+ STJSONSTR = '{"carno":"A12345","city":0,"cjhm":"","ctype":"","cubage":0,'+
+ '"devno":"916704270865","dphone":"13058126562","driver":"","dw":32,"h":0,'+
+ '"id":2,"laddr":"","lat":0,"lbstime":"2014-07-03 19:38:36","length":25,"line"'+
+ ':"ӱ,ɹ,,Ϻ","link":"","lng":114.045173888889,"lphone":"","ltel":'+
+ '"","public":false,"remark":"","sno":"","state":3,"time":"2014-07-22 08:53:45","w":0,"yyzs":""}';
+procedure TForm2.Button10Click(Sender: TObject);
+var
+ json: YxdJson.JSONObject;
+begin
+ json := YxdJson.JSONObject.parseObject(STJSONSTR);
+ try
+ json.getDouble('length');
+ finally
+ json.Free;
+ end;
+ ListBox1.Items.Add(YxdJson.JSONObject.parseStringByName(STJSONSTR, 'dphone'));
+end;
+
+procedure TForm2.Button11Click(Sender: TObject);
+var
+ json: JSONObject;
+ t: Cardinal;
+begin
+ if OpenDialog1.Execute(Self.Handle) then begin
+ t := GetTickCount;
+ json := JSONObject.Create;
+ try
+ json.LoadFromFile(OpenDialog1.FileName);
+ Memo2.Text := json.ToString(4);
+ finally
+ json.Free;
+ end;
+ t := GetTickCount - t;
+ ShowMessage(Format('%s'#13'ļسɹ, ʱ %dms.',
+ [OpenDialog1.FileName, t]));
+ end;
+end;
+
+procedure TForm2.Button12Click(Sender: TObject);
+var
+ json: JSONObject;
+ ja: JSONArray;
+ i, allowAccess: Integer;
+begin
+ json := JSONObject.Create;
+ try
+ json.Parse(Memo2.Text);
+ //ja := json.GetJsonObject('data').GetJsonArray('album');
+ ja := json.ItemByPath('data.album').AsJsonArray;
+ for I := 0 to ja.Count - 1 do
+ allowAccess := ja.GetJsonObject(i).GetInt('allowAccess');
+ finally
+ json.Free;
+ end;
+end;
+
+procedure TForm2.Button16Click(Sender: TObject);
+var
+ json: JSONObject;
+begin
+ ShowMessage(YxdJson.JSONObject.ParseStringByName(Memo1.Text, 'name'));
+ json := YxdJson.JSONObject.ParseObjectByName(Memo1.Text, 'name', 'resKey');
+ if Assigned(json) then begin
+ ShowMessage(json.ToString());
+ FreeAndNil(json);
+ end;
+ Exit;
+ ShowMessage(YxdJson.JSONObject.ParseStringByName(Memo1.Text, 'name'));
+ ShowMessage(YxdJson.JSONObject.ParseStringByName(Memo1.Text, 'asa_id'));
+ ShowMessage(YxdJson.JSONObject.ParseStringByName(Memo1.Text, 'price'));
+ ShowMessage(YxdJson.JSONObject.ParseStringByName(Memo1.Text, 'not_receive'));
+end;
+
+procedure TForm2.Button17Click(Sender: TObject);
+var
+ json: JSONObject;
+begin
+ json := JSONObject.Create;
+ json.AddChildObject('test');
+ ShowMessage(json.ToString());
+ FreeAndNil(json);
+end;
+
+procedure TForm2.Button18Click(Sender: TObject);
+var
+ Json: YxdJson.JSONObject;
+begin
+ Json := YxdJson.JSONObject.Create;
+ try
+ json['aaa.error'].AsString := 'yangyxd';
+ ShowMessage(json.ToString() + #13#10 + json['aaa'].AsString);
+ ShowMessage(json.ToString() + #13#10 + json.S['aaa']);
+ finally
+ FreeAndNil(Json);
+ end;
+end;
+
+procedure TForm2.Button1Click(Sender: TObject);
+var
+ json: YxdJson.JSONObject;
+begin
+ json := YxdJson.JSONObject.parseObject(Memo1.Text);
+ try
+ Memo2.Text := json.toString();
+ //ShowMessage(json[Edit1.Text].AsString);
+ finally
+ json.Free;
+ end;
+end;
+
+procedure TForm2.Button2Click(Sender: TObject);
+var
+ yjson: YxdJson.JSONObject;
+ qjson: TQJson;
+ t, t1: Cardinal;
+ i, j: Integer;
+ s, v, v1: string;
+begin
+ s := Memo1.Text;
+
+ t := GetTickCount;
+ for i := 0 to 20000 - 1 do begin
+ yjson := YxdJson.JSONObject.parseObject(s);
+ v := yjson.toString(4);
+ yjson.Free;
+ end;
+ t := GetTickCount - t;
+
+
+ t1 := GetTickCount;
+ for j := 0 to 20000 - 1 do begin
+ qjson := TQJSon.Create();
+ qjson.parse(s);
+ v1 := qjson.toString();
+ qjson.Free;
+ end;
+ t1 := GetTickCount - t1;
+
+ ListBox1.Items.Add(Format('YxdJson. count: %d, time: %dms.', [i, t]));
+ ListBox1.Items.Add(Format('TQJson. count: %d, time: %dms.', [j, t1]));
+ //ListBox1.Items.Add(Format('UJson. count: %d, time: %dms.', [m, t2]));
+ //ListBox1.Items.Add(Format('uLkJSON. count: %d, time: %dms.', [n, t3]));
+end;
+
+procedure TForm2.Button3Click(Sender: TObject);
+var
+ json: YxdJson.JSONObject;
+begin
+ json := YxdJson.JSONObject.parseObject(Memo1.Text);
+ try
+ Memo2.Text := json.toString(4);
+ finally
+ json.Free;
+ end;
+end;
+
+procedure TForm2.Button4Click(Sender: TObject);
+var
+ yjson: YxdJson.JSONObject;
+ qjson: TQJson;
+ t, t1: Cardinal;
+ i, j: Integer;
+ s, v, v1: string;
+begin
+ s := Memo1.Text;
+
+ t := GetTickCount;
+ yjson := YxdJson.JSONObject.Create;
+ for i := 0 to 20000 - 1 do begin
+ yjson.put('test', 'string');
+ yjson.putDateTime('time', Now);
+ yjson.put('num', 9999);
+ yjson.put('float', 8.88);
+ yjson.putJSON('value', '{"results":[],"status":5,"msg":"AK Illegal or Not Exist:"}');
+ yjson.getFloat('float');
+ yjson.getString('test');
+ yjson.getString('num');
+ yjson.getInt('num');
+ v := yjson.toString(4);
+ //v := yjson.getJsonObject('value').Path;
+ //Memo2.Text := v;
+ yjson.Clear;
+ end;
+ yjson.Free;
+ t := GetTickCount - t;
+
+ t1 := GetTickCount;
+ qjson := TQJSon.Create();
+ for j := 0 to 20000 - 1 do begin
+ qjson.add('test', 'string', jdtString);
+ qjson.AddDateTime('time', Now);
+ qjson.add('num', 9999);
+ qjson.add('float', 8.88);
+ qjson.add('value', '{"results":[],"status":5,"msg":"AK Illegal or Not Exist:"}');
+ qjson.ItemByName('float').AsFloat;
+ qjson.ItemByName('test').AsString;
+ qjson.ItemByName('num').AsString;
+ qjson.ItemByName('num').AsInteger;
+ v1 := qjson.toString();
+ //v1 := qjson.ItemByName('value').Path;
+ qjson.Clear;
+ end;
+ qjson.Free;
+ t1 := GetTickCount - t1;
+
+ Memo2.Text := v;
+
+ ListBox1.Items.Add(Format('YxdJson. count: %d, time: %dms.', [i, t]));
+ ListBox1.Items.Add(Format('TQJson. count: %d, time: %dms.', [j, t1]));
+ //ListBox1.Items.Add(Format('UJson. count: %d, time: %dms.', [m, t2]));
+ //ListBox1.Items.Add(Format('uLkJSON. count: %d, time: %dms.', [n, t3]));
+end;
+
+procedure TForm2.Button5Click(Sender: TObject);
+var
+ json: TQJson;
+begin
+ json := TQJson.Create;
+ try
+ json.Parse(Memo1.Text);
+ Memo2.Text := json.toString();
+ finally
+ json.Free;
+ end;
+end;
+
+procedure TForm2.Button6Click(Sender: TObject);
+var
+ fname: string;
+ yjson: YxdJson.JSONObject;
+ json: TQJson;
+ t, t1: Cardinal;
+ I: Integer;
+ v, v1: string;
+begin
+ fname := ExtractFilePath(Application.ExeName) + 'test.json';
+
+ t := GetTickCount;
+ for i := 0 to 1000 - 1 do begin
+ yjson := YxdJson.JSONObject.Create;
+ try
+ yjson.LoadFromFile(fname);
+ v := yjson.toString(4);
+ yjson.SaveToFile(fname + '.yxdjson.json');
+ finally
+ yjson.Free;
+ end;
+ end;
+ t := GetTickCount - t;
+
+ t1 := GetTickCount;
+ for i := 0 to 1000 - 1 do begin
+ json := TQJson.Create;
+ try
+ json.LoadFromFile(fname);
+ v1 := json.toString();
+ json.SaveToFile(fname + '.qjson.json', {$IFDEF JSON_UNICODE}qstring.teUTF8{$ELSE}qstring.teAnsi{$ENDIF}, true);
+ finally
+ json.Free;
+ end;
+ end;
+ t1 := GetTickCount - t1;
+
+ Memo2.text := v;
+
+ ListBox1.Items.Add(Format('YxdJson.LoadFromFile count: %d, time: %dms.', [i, t]));
+ ListBox1.Items.Add(Format('TQJson. LoadFromFile count: %d, time: %dms.', [i, t1]));
+end;
+
+procedure TForm2.Button7Click(Sender: TObject);
+var
+ fname: string;
+ qjson: TQJson;
+begin
+ fname := ExtractFilePath(Application.ExeName) + 'test.json';
+
+ qjson := TQJson.Create;
+ try
+ qjson.LoadFromFile(fname);
+ Memo2.Text := qjson.toString();
+ finally
+ qjson.Free;
+ end;
+end;
+
+procedure TForm2.Button8Click(Sender: TObject);
+var
+ fname: string;
+ yjson: YxdJson.JSONObject;
+ t, t1, t2: Cardinal;
+ I: Integer;
+ v: string;
+begin
+ fname := ExtractFilePath(Application.ExeName) + 'Preferences.txt';
+ t := GetTickCount;
+ for i := 0 to 1 - 1 do begin
+ yjson := YxdJson.JSONObject.Create;
+ try
+ yjson.LoadFromFile(fname);
+ v := yjson.toString(4);
+ t1 := GetTickCount - t;
+ yjson.SaveToFile(fname + '.yxdjson.json');
+ t2 := GetTickCount - t - t1;
+ finally
+ yjson.Free;
+ end;
+ end;
+ t := GetTickCount - t;
+ ListBox1.Items.add(Format('YJson ʱ%dms, ʱ%dms, %dms', [t1, t2, t]));
+ if CheckBox2.Checked then Memo2.Text := v;
+end;
+
+procedure TForm2.Button9Click(Sender: TObject);
+var
+ fname: string;
+ json: TQJson;
+ t, t1, t2: Cardinal;
+ I: Integer;
+ v: string;
+begin
+ fname := ExtractFilePath(Application.ExeName) + 'Preferences.txt';
+
+ t := GetTickCount;
+ for i := 0 to 1 - 1 do begin
+ json := TQJson.Create;
+ try
+ json.LoadFromFile(fname);
+ v := json.toString();
+ t1 := GetTickCount - t;
+ json.SaveToFile(fname + '.qjson.json', qstring.teAnsi, true);
+ t2 := GetTickCount - t - t1;
+ finally
+ json.Free;
+ end;
+ end;
+ t := GetTickCount - t;
+ ListBox1.Items.add(Format('QJson ʱ%dms, ʱ%dms, %dms', [t1, t2, t]));
+ if CheckBox2.Checked then Memo2.Text := v;
+end;
+
+procedure TForm2.FormCreate(Sender: TObject);
+begin
+ OpenDialog1.InitialDir := ExtractFilePath(ParamStr(0));
+end;
+
+procedure TForm2.N1Click(Sender: TObject);
+begin
+ ListBox1.Clear;
+end;
+
+end.
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/superobject.pas" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/superobject.pas"
new file mode 100644
index 0000000..191d53d
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/superobject.pas"
@@ -0,0 +1,6555 @@
+(*
+ * Super Object Toolkit
+ *
+ * Usage allowed under the restrictions of the Lesser GNU General Public License
+ * or alternatively the restrictions of the Mozilla Public License 1.1
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ * the specific language governing rights and limitations under the License.
+ *
+ * Unit owner : Henri Gourvest
+ * Web site : http://www.progdigy.com
+ *
+ * This unit is inspired from the json c lib:
+ * Michael Clark
+ * http://oss.metaparadigm.com/json-c/
+ *
+ * CHANGES:
+ * v1.2
+ * + support of currency data type
+ * + right trim unquoted string
+ * + read Unicode Files and streams (Litle Endian with BOM)
+ * + Fix bug on javadate functions + windows nt compatibility
+ * + Now you can force to parse only the canonical syntax of JSON using the stric parameter
+ * + Delphi 2010 RTTI marshalling
+ * v1.1
+ * + Double licence MPL or LGPL.
+ * + Delphi 2009 compatibility & Unicode support.
+ * + AsString return a string instead of PChar.
+ * + Escaped and Unascaped JSON serialiser.
+ * + Missed FormFeed added \f
+ * - Removed @ trick, uses forcepath() method instead.
+ * + Fixed parse error with uppercase E symbol in numbers.
+ * + Fixed possible buffer overflow when enlarging array.
+ * + Added "delete", "pack", "insert" methods for arrays and/or objects
+ * + Multi parametters when calling methods
+ * + Delphi Enumerator (for obj1 in obj2 do ...)
+ * + Format method ex: obj.format('<%name%>%tab[1]%')
+ * + ParseFile and ParseStream methods
+ * + Parser now understand hexdecimal c syntax ex: \xFF
+ * + Null Object Design Patern (ex: for obj in values.N['path'] do ...)
+ * v1.0
+ * + renamed class
+ * + interfaced object
+ * + added a new data type: the method
+ * + parser can now evaluate properties and call methods
+ * - removed obselet rpc class
+ * - removed "find" method, now you can use "parse" method instead
+ * v0.6
+ * + refactoring
+ * v0.5
+ * + new find method to get or set value using a path syntax
+ * ex: obj.s['obj.prop[1]'] := 'string value';
+ * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary
+ * v0.4
+ * + bug corrected: AVL tree badly balanced.
+ * v0.3
+ * + New validator partially based on the Kwalify syntax.
+ * + extended syntax to parse unquoted fields.
+ * + Freepascal compatibility win32/64 Linux32/64.
+ * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC.
+ * + new TJsonObject.Compare function.
+ * v0.2
+ * + Hashed string list replaced with a faster AVL tree
+ * + JsonInt data type can be changed to int64
+ * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions
+ * + from json-c v0.7
+ * + Add escaping of backslash to json output
+ * + Add escaping of foward slash on tokenizing and output
+ * + Changes to internal tokenizer from using recursion to
+ * using a depth state structure to allow incremental parsing
+ * v0.1
+ * + first release
+ *)
+
+{$IFDEF FPC}
+ {$MODE OBJFPC}{$H+}
+{$ENDIF}
+
+{$DEFINE SUPER_METHOD}
+{$DEFINE WINDOWSNT_COMPATIBILITY}
+{.$DEFINE DEBUG} // track memory leack
+
+unit superobject;
+
+interface
+uses
+ Classes
+{$IFDEF VER210}
+ ,Generics.Collections, RTTI, TypInfo
+{$ENDIF}
+ ;
+
+type
+{$IFNDEF FPC}
+ PtrInt = longint;
+ PtrUInt = Longword;
+{$ENDIF}
+ SuperInt = Int64;
+
+{$if (sizeof(Char) = 1)}
+ SOChar = WideChar;
+ SOIChar = Word;
+ PSOChar = PWideChar;
+ SOString = WideString;
+{$else}
+ SOChar = Char;
+ SOIChar = Word;
+ PSOChar = PChar;
+ SOString = string;
+{$ifend}
+
+const
+ SUPER_ARRAY_LIST_DEFAULT_SIZE = 32;
+ SUPER_TOKENER_MAX_DEPTH = 32;
+
+ SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8;
+ SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1);
+
+type
+ // forward declarations
+ TSuperObject = class;
+ ISuperObject = interface;
+ TSuperArray = class;
+
+(* AVL Tree
+ * This is a "special" autobalanced AVL tree
+ * It use a hash value for fast compare
+ *)
+
+{$IFDEF SUPER_METHOD}
+ TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject);
+{$ENDIF}
+
+
+ TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1;
+
+ TSuperAvlSearchType = (stEQual, stLess, stGreater);
+ TSuperAvlSearchTypes = set of TSuperAvlSearchType;
+ TSuperAvlIterator = class;
+
+ TSuperAvlEntry = class
+ private
+ FGt, FLt: TSuperAvlEntry;
+ FBf: integer;
+ FHash: Cardinal;
+ FName: SOString;
+ FPtr: Pointer;
+ function GetValue: ISuperObject;
+ procedure SetValue(const val: ISuperObject);
+ public
+ class function Hash(const k: SOString): Cardinal; virtual;
+ constructor Create(const AName: SOString; Obj: Pointer); virtual;
+ property Name: SOString read FName;
+ property Ptr: Pointer read FPtr;
+ property Value: ISuperObject read GetValue write SetValue;
+ end;
+
+ TSuperAvlTree = class
+ private
+ FRoot: TSuperAvlEntry;
+ FCount: Integer;
+ function balance(bal: TSuperAvlEntry): TSuperAvlEntry;
+ protected
+ procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual;
+ function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual;
+ function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual;
+ function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual;
+ function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual;
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function IsEmpty: boolean;
+ procedure Clear(all: boolean = false); virtual;
+ procedure Pack(all: boolean);
+ function Delete(const k: SOString): ISuperObject;
+ function GetEnumerator: TSuperAvlIterator;
+ property count: Integer read FCount;
+ end;
+
+ TSuperTableString = class(TSuperAvlTree)
+ protected
+ procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override;
+ procedure PutO(const k: SOString; const value: ISuperObject);
+ function GetO(const k: SOString): ISuperObject;
+ procedure PutS(const k: SOString; const value: SOString);
+ function GetS(const k: SOString): SOString;
+ procedure PutI(const k: SOString; value: SuperInt);
+ function GetI(const k: SOString): SuperInt;
+ procedure PutD(const k: SOString; value: Double);
+ function GetD(const k: SOString): Double;
+ procedure PutB(const k: SOString; value: Boolean);
+ function GetB(const k: SOString): Boolean;
+{$IFDEF SUPER_METHOD}
+ procedure PutM(const k: SOString; value: TSuperMethod);
+ function GetM(const k: SOString): TSuperMethod;
+{$ENDIF}
+ procedure PutN(const k: SOString; const value: ISuperObject);
+ function GetN(const k: SOString): ISuperObject;
+ procedure PutC(const k: SOString; value: Currency);
+ function GetC(const k: SOString): Currency;
+ public
+ property O[const k: SOString]: ISuperObject read GetO write PutO; default;
+ property S[const k: SOString]: SOString read GetS write PutS;
+ property I[const k: SOString]: SuperInt read GetI write PutI;
+ property D[const k: SOString]: Double read GetD write PutD;
+ property B[const k: SOString]: Boolean read GetB write PutB;
+{$IFDEF SUPER_METHOD}
+ property M[const k: SOString]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+ property N[const k: SOString]: ISuperObject read GetN write PutN;
+ property C[const k: SOString]: Currency read GetC write PutC;
+
+ function GetValues: ISuperObject;
+ function GetNames: ISuperObject;
+ end;
+
+ TSuperAvlIterator = class
+ private
+ FTree: TSuperAvlTree;
+ FBranch: TSuperAvlBitArray;
+ FDepth: LongInt;
+ FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry;
+ public
+ constructor Create(tree: TSuperAvlTree); virtual;
+ procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]);
+ procedure First;
+ procedure Last;
+ function GetIter: TSuperAvlEntry;
+ procedure Next;
+ procedure Prior;
+ // delphi enumerator
+ function MoveNext: Boolean;
+ property Current: TSuperAvlEntry read GetIter;
+ end;
+
+ TSuperObjectArray = array[0..(high(PtrInt) div sizeof(TSuperObject))-1] of ISuperObject;
+ PSuperObjectArray = ^TSuperObjectArray;
+
+ TSuperArray = class
+ private
+ FArray: PSuperObjectArray;
+ FLength: Integer;
+ FSize: Integer;
+ procedure Expand(max: Integer);
+ protected
+ function GetO(const index: integer): ISuperObject;
+ procedure PutO(const index: integer; const Value: ISuperObject);
+ function GetB(const index: integer): Boolean;
+ procedure PutB(const index: integer; Value: Boolean);
+ function GetI(const index: integer): SuperInt;
+ procedure PutI(const index: integer; Value: SuperInt);
+ function GetD(const index: integer): Double;
+ procedure PutD(const index: integer; Value: Double);
+ function GetC(const index: integer): Currency;
+ procedure PutC(const index: integer; Value: Currency);
+ function GetS(const index: integer): SOString;
+ procedure PutS(const index: integer; const Value: SOString);
+{$IFDEF SUPER_METHOD}
+ function GetM(const index: integer): TSuperMethod;
+ procedure PutM(const index: integer; Value: TSuperMethod);
+{$ENDIF}
+ function GetN(const index: integer): ISuperObject;
+ procedure PutN(const index: integer; const Value: ISuperObject);
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function Add(const Data: ISuperObject): Integer;
+ function Delete(index: Integer): ISuperObject;
+ procedure Insert(index: Integer; const value: ISuperObject);
+ procedure Clear(all: boolean = false);
+ procedure Pack(all: boolean);
+ property Length: Integer read FLength;
+
+ property N[const index: integer]: ISuperObject read GetN write PutN;
+ property O[const index: integer]: ISuperObject read GetO write PutO; default;
+ property B[const index: integer]: boolean read GetB write PutB;
+ property I[const index: integer]: SuperInt read GetI write PutI;
+ property D[const index: integer]: Double read GetD write PutD;
+ property C[const index: integer]: Currency read GetC write PutC;
+ property S[const index: integer]: SOString read GetS write PutS;
+{$IFDEF SUPER_METHOD}
+ property M[const index: integer]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+// property A[const index: integer]: TSuperArray read GetA;
+ end;
+
+ TSuperWriter = class
+ public
+ // abstact methods to overide
+ function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract;
+ function Append(buf: PSOChar): Integer; overload; virtual; abstract;
+ procedure Reset; virtual; abstract;
+ end;
+
+ TSuperWriterString = class(TSuperWriter)
+ private
+ FBuf: PSOChar;
+ FBPos: integer;
+ FSize: integer;
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; overload; override;
+ function Append(buf: PSOChar): Integer; overload; override;
+ procedure Reset; override;
+ procedure TrimRight;
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function GetString: SOString;
+ property Data: PSOChar read FBuf;
+ property Size: Integer read FSize;
+ property Position: integer read FBPos;
+ end;
+
+ TSuperWriterStream = class(TSuperWriter)
+ private
+ FStream: TStream;
+ public
+ function Append(buf: PSOChar): Integer; override;
+ procedure Reset; override;
+ constructor Create(AStream: TStream); reintroduce; virtual;
+ end;
+
+ TSuperAnsiWriterStream = class(TSuperWriterStream)
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ end;
+
+ TSuperUnicodeWriterStream = class(TSuperWriterStream)
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ end;
+
+ TSuperWriterFake = class(TSuperWriter)
+ private
+ FSize: Integer;
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ function Append(buf: PSOChar): Integer; override;
+ procedure Reset; override;
+ constructor Create; reintroduce; virtual;
+ property size: integer read FSize;
+ end;
+
+ TSuperWriterSock = class(TSuperWriter)
+ private
+ FSocket: longint;
+ FSize: Integer;
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ function Append(buf: PSOChar): Integer; override;
+ procedure Reset; override;
+ constructor Create(ASocket: longint); reintroduce; virtual;
+ property Socket: longint read FSocket;
+ property Size: Integer read FSize;
+ end;
+
+ TSuperTokenizerError = (
+ teSuccess,
+ teContinue,
+ teDepth,
+ teParseEof,
+ teParseUnexpected,
+ teParseNull,
+ teParseBoolean,
+ teParseNumber,
+ teParseArray,
+ teParseObjectKeyName,
+ teParseObjectKeySep,
+ teParseObjectValueSep,
+ teParseString,
+ teParseComment,
+ teEvalObject,
+ teEvalArray,
+ teEvalMethod,
+ teEvalInt
+ );
+
+ TSuperTokenerState = (
+ tsEatws,
+ tsStart,
+ tsFinish,
+ tsNull,
+ tsCommentStart,
+ tsComment,
+ tsCommentEol,
+ tsCommentEnd,
+ tsString,
+ tsStringEscape,
+ tsIdentifier,
+ tsEscapeUnicode,
+ tsEscapeHexadecimal,
+ tsBoolean,
+ tsNumber,
+ tsArray,
+ tsArrayAdd,
+ tsArraySep,
+ tsObjectFieldStart,
+ tsObjectField,
+ tsObjectUnquotedField,
+ tsObjectFieldEnd,
+ tsObjectValue,
+ tsObjectValueAdd,
+ tsObjectSep,
+ tsEvalProperty,
+ tsEvalArray,
+ tsEvalMethod,
+ tsParamValue,
+ tsParamPut,
+ tsMethodValue,
+ tsMethodPut
+ );
+
+ PSuperTokenerSrec = ^TSuperTokenerSrec;
+ TSuperTokenerSrec = record
+ state, saved_state: TSuperTokenerState;
+ obj: ISuperObject;
+ current: ISuperObject;
+ field_name: SOString;
+ parent: ISuperObject;
+ gparent: ISuperObject;
+ end;
+
+ TSuperTokenizer = class
+ public
+ str: PSOChar;
+ pb: TSuperWriterString;
+ depth, is_double, floatcount, st_pos, char_offset: Integer;
+ err: TSuperTokenizerError;
+ ucs_char: Word;
+ quote_char: SOChar;
+ stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec;
+ line, col: Integer;
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+ procedure ResetLevel(adepth: integer);
+ procedure Reset;
+ end;
+
+ // supported object types
+ TSuperType = (
+ stNull,
+ stBoolean,
+ stDouble,
+ stCurrency,
+ stInt,
+ stObject,
+ stArray,
+ stString
+{$IFDEF SUPER_METHOD}
+ ,stMethod
+{$ENDIF}
+ );
+
+ TSuperValidateError = (
+ veRuleMalformated,
+ veFieldIsRequired,
+ veInvalidDataType,
+ veFieldNotFound,
+ veUnexpectedField,
+ veDuplicateEntry,
+ veValueNotInEnum,
+ veInvalidLength,
+ veInvalidRange
+ );
+
+ TSuperFindOption = (
+ foCreatePath,
+ foPutValue,
+ foDelete
+{$IFDEF SUPER_METHOD}
+ ,foCallMethod
+{$ENDIF}
+ );
+
+ TSuperFindOptions = set of TSuperFindOption;
+ TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError);
+ TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString);
+
+ TSuperEnumerator = class
+ private
+ FObj: ISuperObject;
+ FObjEnum: TSuperAvlIterator;
+ FCount: Integer;
+ public
+ constructor Create(const obj: ISuperObject); virtual;
+ destructor Destroy; override;
+ function MoveNext: Boolean;
+ function GetCurrent: ISuperObject;
+ property Current: ISuperObject read GetCurrent;
+ end;
+
+ ISuperObject = interface
+ ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}']
+ function GetEnumerator: TSuperEnumerator;
+ function GetDataType: TSuperType;
+ function GetProcessing: boolean;
+ procedure SetProcessing(value: boolean);
+ function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
+ function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
+
+ function GetO(const path: SOString): ISuperObject;
+ procedure PutO(const path: SOString; const Value: ISuperObject);
+ function GetB(const path: SOString): Boolean;
+ procedure PutB(const path: SOString; Value: Boolean);
+ function GetI(const path: SOString): SuperInt;
+ procedure PutI(const path: SOString; Value: SuperInt);
+ function GetD(const path: SOString): Double;
+ procedure PutC(const path: SOString; Value: Currency);
+ function GetC(const path: SOString): Currency;
+ procedure PutD(const path: SOString; Value: Double);
+ function GetS(const path: SOString): SOString;
+ procedure PutS(const path: SOString; const Value: SOString);
+{$IFDEF SUPER_METHOD}
+ function GetM(const path: SOString): TSuperMethod;
+ procedure PutM(const path: SOString; Value: TSuperMethod);
+{$ENDIF}
+ function GetA(const path: SOString): TSuperArray;
+
+ // Null Object Design patern
+ function GetN(const path: SOString): ISuperObject;
+ procedure PutN(const path: SOString; const Value: ISuperObject);
+
+ // Writers
+ function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
+ function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
+ function CalcSize(indent: boolean = false; escape: boolean = true): integer;
+
+ // convert
+ function AsBoolean: Boolean;
+ function AsInteger: SuperInt;
+ function AsDouble: Double;
+ function AsCurrency: Currency;
+ function AsString: SOString;
+ function AsArray: TSuperArray;
+ function AsObject: TSuperTableString;
+{$IFDEF SUPER_METHOD}
+ function AsMethod: TSuperMethod;
+{$ENDIF}
+ function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
+
+ procedure Clear(all: boolean = false);
+ procedure Pack(all: boolean = false);
+
+ property N[const path: SOString]: ISuperObject read GetN write PutN;
+ property O[const path: SOString]: ISuperObject read GetO write PutO; default;
+ property B[const path: SOString]: boolean read GetB write PutB;
+ property I[const path: SOString]: SuperInt read GetI write PutI;
+ property D[const path: SOString]: Double read GetD write PutD;
+ property C[const path: SOString]: Currency read GetC write PutC;
+ property S[const path: SOString]: SOString read GetS write PutS;
+{$IFDEF SUPER_METHOD}
+ property M[const path: SOString]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+ property A[const path: SOString]: TSuperArray read GetA;
+
+{$IFDEF SUPER_METHOD}
+ function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload;
+ function call(const path, param: SOString): ISuperObject; overload;
+{$ENDIF}
+ // clone a node
+ function Clone: ISuperObject;
+ function Delete(const path: SOString): ISuperObject;
+ // merges tow objects of same type, if reference is true then nodes are not cloned
+ procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
+ procedure Merge(const str: SOString); overload;
+
+ // validate methods
+ function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+ function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+
+ // compare
+ function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
+ function Compare(const str: SOString): TSuperCompareResult; overload;
+
+ // the data type
+ function IsType(AType: TSuperType): boolean;
+ property DataType: TSuperType read GetDataType;
+ property Processing: boolean read GetProcessing write SetProcessing;
+
+ function GetDataPtr: Pointer;
+ procedure SetDataPtr(const Value: Pointer);
+ property DataPtr: Pointer read GetDataPtr write SetDataPtr;
+ end;
+
+ TSuperObject = class(TObject, ISuperObject)
+ private
+ FRefCount: Integer;
+ FProcessing: boolean;
+ FDataType: TSuperType;
+ FDataPtr: Pointer;
+{.$if true}
+ FO: record
+ case TSuperType of
+ stBoolean: (c_boolean: boolean);
+ stDouble: (c_double: double);
+ stCurrency: (c_currency: Currency);
+ stInt: (c_int: SuperInt);
+ stObject: (c_object: TSuperTableString);
+ stArray: (c_array: TSuperArray);
+{$IFDEF SUPER_METHOD}
+ stMethod: (c_method: TSuperMethod);
+{$ENDIF}
+ end;
+{.$ifend}
+ FOString: SOString;
+ function GetDataType: TSuperType;
+ function GetDataPtr: Pointer;
+ procedure SetDataPtr(const Value: Pointer);
+ protected
+ function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
+ function _AddRef: Integer; virtual; stdcall;
+ function _Release: Integer; virtual; stdcall;
+
+ function GetO(const path: SOString): ISuperObject;
+ procedure PutO(const path: SOString; const Value: ISuperObject);
+ function GetB(const path: SOString): Boolean;
+ procedure PutB(const path: SOString; Value: Boolean);
+ function GetI(const path: SOString): SuperInt;
+ procedure PutI(const path: SOString; Value: SuperInt);
+ function GetD(const path: SOString): Double;
+ procedure PutD(const path: SOString; Value: Double);
+ procedure PutC(const path: SOString; Value: Currency);
+ function GetC(const path: SOString): Currency;
+ function GetS(const path: SOString): SOString;
+ procedure PutS(const path: SOString; const Value: SOString);
+{$IFDEF SUPER_METHOD}
+ function GetM(const path: SOString): TSuperMethod;
+ procedure PutM(const path: SOString; Value: TSuperMethod);
+{$ENDIF}
+ function GetA(const path: SOString): TSuperArray;
+ function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual;
+ public
+ function GetEnumerator: TSuperEnumerator;
+ procedure AfterConstruction; override;
+ procedure BeforeDestruction; override;
+ class function NewInstance: TObject; override;
+ property RefCount: Integer read FRefCount;
+
+ function GetProcessing: boolean;
+ procedure SetProcessing(value: boolean);
+
+ // Writers
+ function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
+ function CalcSize(indent: boolean = false; escape: boolean = true): integer;
+ function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
+
+ // parser ... owned!
+ class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
+ const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+ class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
+ const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+ class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
+ const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+ class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil;
+ options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+
+ // constructors / destructor
+ constructor Create(jt: TSuperType = stObject); overload; virtual;
+ constructor Create(b: boolean); overload; virtual;
+ constructor Create(i: SuperInt); overload; virtual;
+ constructor Create(d: double); overload; virtual;
+ constructor CreateCurrency(c: Currency); overload; virtual;
+ constructor Create(const s: SOString); overload; virtual;
+{$IFDEF SUPER_METHOD}
+ constructor Create(m: TSuperMethod); overload; virtual;
+{$ENDIF}
+ destructor Destroy; override;
+
+ // convert
+ function AsBoolean: Boolean; virtual;
+ function AsInteger: SuperInt; virtual;
+ function AsDouble: Double; virtual;
+ function AsCurrency: Currency; virtual;
+ function AsString: SOString; virtual;
+ function AsArray: TSuperArray; virtual;
+ function AsObject: TSuperTableString; virtual;
+{$IFDEF SUPER_METHOD}
+ function AsMethod: TSuperMethod; virtual;
+{$ENDIF}
+ procedure Clear(all: boolean = false); virtual;
+ procedure Pack(all: boolean = false); virtual;
+ function GetN(const path: SOString): ISuperObject;
+ procedure PutN(const path: SOString; const Value: ISuperObject);
+ function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
+ function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
+
+ property N[const path: SOString]: ISuperObject read GetN write PutN;
+ property O[const path: SOString]: ISuperObject read GetO write PutO; default;
+ property B[const path: SOString]: boolean read GetB write PutB;
+ property I[const path: SOString]: SuperInt read GetI write PutI;
+ property D[const path: SOString]: Double read GetD write PutD;
+ property C[const path: SOString]: Currency read GetC write PutC;
+ property S[const path: SOString]: SOString read GetS write PutS;
+{$IFDEF SUPER_METHOD}
+ property M[const path: SOString]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+ property A[const path: SOString]: TSuperArray read GetA;
+
+{$IFDEF SUPER_METHOD}
+ function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual;
+ function call(const path, param: SOString): ISuperObject; overload; virtual;
+{$ENDIF}
+ // clone a node
+ function Clone: ISuperObject; virtual;
+ function Delete(const path: SOString): ISuperObject;
+ // merges tow objects of same type, if reference is true then nodes are not cloned
+ procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
+ procedure Merge(const str: SOString); overload;
+
+ // validate methods
+ function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+ function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+
+ // compare
+ function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
+ function Compare(const str: SOString): TSuperCompareResult; overload;
+
+ // the data type
+ function IsType(AType: TSuperType): boolean;
+ property DataType: TSuperType read GetDataType;
+ // a data pointer to link to something ele, a treeview for example
+ property DataPtr: Pointer read GetDataPtr write SetDataPtr;
+ property Processing: boolean read GetProcessing;
+ end;
+
+{$IFDEF VER210}
+ TSuperRttiContext = class;
+
+ TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+ TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+
+ TSuperAttribute = class(TCustomAttribute)
+ private
+ FName: string;
+ public
+ constructor Create(const AName: string);
+ property Name: string read FName;
+ end;
+
+ SOName = class(TSuperAttribute);
+ SODefault = class(TSuperAttribute);
+
+
+ TSuperRttiContext = class
+ private
+ class function GetFieldName(r: TRttiField): string;
+ class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
+ public
+ Context: TRttiContext;
+ SerialFromJson: TDictionary;
+ SerialToJson: TDictionary;
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual;
+ function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual;
+ function AsType(const obj: ISuperObject): T;
+ function AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject;
+ end;
+
+ TSuperObjectHelper = class helper for TObject
+ public
+ function ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
+ constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload;
+ constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload;
+ end;
+{$ENDIF}
+
+ TSuperObjectIter = record
+ key: SOString;
+ val: ISuperObject;
+ Ite: TSuperAvlIterator;
+ end;
+
+function ObjectIsError(obj: TSuperObject): boolean;
+function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
+function ObjectGetType(const obj: ISuperObject): TSuperType;
+
+function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
+function ObjectFindNext(var F: TSuperObjectIter): boolean;
+procedure ObjectFindClose(var F: TSuperObjectIter);
+
+function SO(const s: SOString = '{}'): ISuperObject; overload;
+function SO(const value: Variant): ISuperObject; overload;
+function SO(const Args: array of const): ISuperObject; overload;
+
+function SA(const Args: array of const): ISuperObject; overload;
+
+function JavaToDelphiDateTime(const dt: int64): TDateTime;
+function DelphiToJavaDateTime(const dt: TDateTime): int64;
+
+{$IFDEF VER210}
+
+type
+ TSuperInvokeResult = (
+ irSuccess,
+ irMethothodError, // method don't exist
+ irParamError, // invalid parametters
+ irError // other error
+ );
+
+function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload;
+function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload;
+function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload;
+{$ENDIF}
+
+implementation
+uses sysutils,
+{$IFDEF UNIX}
+ baseunix, unix, DateUtils
+{$ELSE}
+ Windows
+{$ENDIF}
+{$IFDEF FPC}
+ ,sockets
+{$ELSE}
+ ,WinSock
+{$ENDIF};
+
+{$IFDEF DEBUG}
+var
+ debugcount: integer = 0;
+{$ENDIF}
+
+const
+ super_number_chars_set = ['0'..'9','.','+','-','e','E'];
+ super_hex_chars: PSOChar = '0123456789abcdef';
+ super_hex_chars_set = ['0'..'9','a'..'f','A'..'F'];
+
+ ESC_BS: PSOChar = '\b';
+ ESC_LF: PSOChar = '\n';
+ ESC_CR: PSOChar = '\r';
+ ESC_TAB: PSOChar = '\t';
+ ESC_FF: PSOChar = '\f';
+ ESC_QUOT: PSOChar = '\"';
+ ESC_SL: PSOChar = '\\';
+ ESC_SR: PSOChar = '\/';
+ ESC_ZERO: PSOChar = '\u0000';
+
+ TOK_CRLF: PSOChar = #13#10;
+ TOK_SP: PSOChar = #32;
+ TOK_BS: PSOChar = #8;
+ TOK_TAB: PSOChar = #9;
+ TOK_LF: PSOChar = #10;
+ TOK_FF: PSOChar = #12;
+ TOK_CR: PSOChar = #13;
+// TOK_SL: PSOChar = '\';
+// TOK_SR: PSOChar = '/';
+ TOK_NULL: PSOChar = 'null';
+ TOK_CBL: PSOChar = '{'; // curly bracket left
+ TOK_CBR: PSOChar = '}'; // curly bracket right
+ TOK_ARL: PSOChar = '[';
+ TOK_ARR: PSOChar = ']';
+ TOK_ARRAY: PSOChar = '[]';
+ TOK_OBJ: PSOChar = '{}'; // empty object
+ TOK_COM: PSOChar = ','; // Comma
+ TOK_DQT: PSOChar = '"'; // Double Quote
+ TOK_TRUE: PSOChar = 'true';
+ TOK_FALSE: PSOChar = 'false';
+
+{$if (sizeof(Char) = 1)}
+function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer;
+var
+ P1, P2: PWideChar;
+ I: Cardinal;
+ C1, C2: WideChar;
+begin
+ P1 := Str1;
+ P2 := Str2;
+ I := 0;
+ while I < MaxLen do
+ begin
+ C1 := P1^;
+ C2 := P2^;
+
+ if (C1 <> C2) or (C1 = #0) then
+ begin
+ Result := Ord(C1) - Ord(C2);
+ Exit;
+ end;
+
+ Inc(P1);
+ Inc(P2);
+ Inc(I);
+ end;
+ Result := 0;
+end;
+
+function StrComp(const Str1, Str2: PSOChar): Integer;
+var
+ P1, P2: PWideChar;
+ C1, C2: WideChar;
+begin
+ P1 := Str1;
+ P2 := Str2;
+ while True do
+ begin
+ C1 := P1^;
+ C2 := P2^;
+
+ if (C1 <> C2) or (C1 = #0) then
+ begin
+ Result := Ord(C1) - Ord(C2);
+ Exit;
+ end;
+
+ Inc(P1);
+ Inc(P2);
+ end;
+end;
+
+function StrLen(const Str: PSOChar): Cardinal;
+var
+ p: PSOChar;
+begin
+ Result := 0;
+ if Str <> nil then
+ begin
+ p := Str;
+ while p^ <> #0 do inc(p);
+ Result := (p - Str);
+ end;
+end;
+{$ifend}
+
+function CurrToStr(c: Currency): SOString;
+var
+ p: PSOChar;
+ i, len: Integer;
+begin
+ Result := IntToStr(Abs(PInt64(@c)^));
+ len := Length(Result);
+ SetLength(Result, len+1);
+ if c <> 0 then
+ begin
+ while len <= 4 do
+ begin
+ Result := '0' + Result;
+ inc(len);
+ end;
+
+ p := PSOChar(Result);
+ inc(p, len-1);
+ i := 0;
+ repeat
+ if p^ <> '0' then
+ begin
+ len := len - i + 1;
+ repeat
+ p[1] := p^;
+ dec(p);
+ inc(i);
+ until i > 3;
+ Break;
+ end;
+ dec(p);
+ inc(i);
+ if i > 3 then
+ begin
+ len := len - i + 1;
+ Break;
+ end;
+ until false;
+ p[1] := '.';
+ SetLength(Result, len);
+ if c < 0 then
+ Result := '-' + Result;
+ end;
+end;
+
+{$IFDEF UNIX}
+ {$linklib c}
+{$ENDIF}
+function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl;
+ external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF};
+
+{$IFDEF UNIX}
+type
+ ptm = ^tm;
+ tm = record
+ tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *)
+ tm_min: Integer; (* Minutes: 0-59 *)
+ tm_hour: Integer; (* Hours since midnight: 0-23 *)
+ tm_mday: Integer; (* Day of the month: 1-31 *)
+ tm_mon: Integer; (* Months *since* january: 0-11 *)
+ tm_year: Integer; (* Years since 1900 *)
+ tm_wday: Integer; (* Days since Sunday (0-6) *)
+ tm_yday: Integer; (* Days since Jan. 1: 0-365 *)
+ tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *)
+ end;
+
+function mktime(p: ptm): LongInt; cdecl; external;
+function gmtime(const t: PLongint): ptm; cdecl; external;
+function localtime (const t: PLongint): ptm; cdecl; external;
+
+function DelphiToJavaDateTime(const dt: TDateTime): Int64;
+var
+ p: ptm;
+ l, ms: Integer;
+ v: Int64;
+begin
+ v := Round((dt - 25569) * 86400000);
+ ms := v mod 1000;
+ l := v div 1000;
+ p := localtime(@l);
+ Result := Int64(mktime(p)) * 1000 + ms;
+end;
+
+function JavaToDelphiDateTime(const dt: int64): TDateTime;
+var
+ p: ptm;
+ l, ms: Integer;
+begin
+ l := dt div 1000;
+ ms := dt mod 1000;
+ p := gmtime(@l);
+ Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms);
+end;
+{$ELSE}
+
+{$IFDEF WINDOWSNT_COMPATIBILITY}
+function DayLightCompareDate(const date: PSystemTime;
+ const compareDate: PSystemTime): Integer;
+var
+ limit_day, dayinsecs, weekofmonth: Integer;
+ First: Word;
+begin
+ if (date^.wMonth < compareDate^.wMonth) then
+ begin
+ Result := -1; (* We are in a month before the date limit. *)
+ Exit;
+ end;
+
+ if (date^.wMonth > compareDate^.wMonth) then
+ begin
+ Result := 1; (* We are in a month after the date limit. *)
+ Exit;
+ end;
+
+ (* if year is 0 then date is in day-of-week format, otherwise
+ * it's absolute date.
+ *)
+ if (compareDate^.wYear = 0) then
+ begin
+ (* compareDate.wDay is interpreted as number of the week in the month
+ * 5 means: the last week in the month *)
+ weekofmonth := compareDate^.wDay;
+ (* calculate the day of the first DayOfWeek in the month *)
+ First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1;
+ limit_day := First + 7 * (weekofmonth - 1);
+ (* check needed for the 5th weekday of the month *)
+ if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth - 1]) then
+ dec(limit_day, 7);
+ end
+ else
+ limit_day := compareDate^.wDay;
+
+ (* convert to seconds *)
+ limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60;
+ dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond;
+ (* and compare *)
+
+ if dayinsecs < limit_day then
+ Result := -1 else
+ if dayinsecs > limit_day then
+ Result := 1 else
+ Result := 0; (* date is equal to the date limit. *)
+end;
+
+function CompTimeZoneID(const pTZinfo: PTimeZoneInformation;
+ lpFileTime: PFileTime; islocal: Boolean): LongWord;
+var
+ ret: Integer;
+ beforeStandardDate, afterDaylightDate: Boolean;
+ llTime: Int64;
+ SysTime: TSystemTime;
+ ftTemp: TFileTime;
+begin
+ llTime := 0;
+
+ if (pTZinfo^.DaylightDate.wMonth <> 0) then
+ begin
+ (* if year is 0 then date is in day-of-week format, otherwise
+ * it's absolute date.
+ *)
+ if ((pTZinfo^.StandardDate.wMonth = 0) or
+ ((pTZinfo^.StandardDate.wYear = 0) and
+ ((pTZinfo^.StandardDate.wDay < 1) or
+ (pTZinfo^.StandardDate.wDay > 5) or
+ (pTZinfo^.DaylightDate.wDay < 1) or
+ (pTZinfo^.DaylightDate.wDay > 5)))) then
+ begin
+ SetLastError(ERROR_INVALID_PARAMETER);
+ Result := TIME_ZONE_ID_INVALID;
+ Exit;
+ end;
+
+ if (not islocal) then
+ begin
+ llTime := PInt64(lpFileTime)^;
+ dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000);
+ PInt64(@ftTemp)^ := llTime;
+ lpFileTime := @ftTemp;
+ end;
+
+ FileTimeToSystemTime(lpFileTime^, SysTime);
+
+ (* check for daylight savings *)
+ ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate);
+ if (ret = -2) then
+ begin
+ Result := TIME_ZONE_ID_INVALID;
+ Exit;
+ end;
+
+ beforeStandardDate := ret < 0;
+
+ if (not islocal) then
+ begin
+ dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000);
+ PInt64(@ftTemp)^ := llTime;
+ FileTimeToSystemTime(lpFileTime^, SysTime);
+ end;
+
+ ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate);
+ if (ret = -2) then
+ begin
+ Result := TIME_ZONE_ID_INVALID;
+ Exit;
+ end;
+
+ afterDaylightDate := ret >= 0;
+
+ Result := TIME_ZONE_ID_STANDARD;
+ if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then
+ begin
+ (* Northern hemisphere *)
+ if( beforeStandardDate and afterDaylightDate) then
+ Result := TIME_ZONE_ID_DAYLIGHT;
+ end else (* Down south *)
+ if( beforeStandardDate or afterDaylightDate) then
+ Result := TIME_ZONE_ID_DAYLIGHT;
+ end else
+ (* No transition date *)
+ Result := TIME_ZONE_ID_UNKNOWN;
+end;
+
+function GetTimezoneBias(const pTZinfo: PTimeZoneInformation;
+ lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean;
+var
+ bias: LongInt;
+ tzid: LongWord;
+begin
+ bias := pTZinfo^.Bias;
+ tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal);
+
+ if( tzid = TIME_ZONE_ID_INVALID) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ if (tzid = TIME_ZONE_ID_DAYLIGHT) then
+ inc(bias, pTZinfo^.DaylightBias)
+ else if (tzid = TIME_ZONE_ID_STANDARD) then
+ inc(bias, pTZinfo^.StandardBias);
+ pBias^ := bias;
+ Result := True;
+end;
+
+function SystemTimeToTzSpecificLocalTime(
+ lpTimeZoneInformation: PTimeZoneInformation;
+ lpUniversalTime, lpLocalTime: PSystemTime): BOOL;
+var
+ ft: TFileTime;
+ lBias: LongInt;
+ llTime: Int64;
+ tzinfo: TTimeZoneInformation;
+begin
+ if (lpTimeZoneInformation <> nil) then
+ tzinfo := lpTimeZoneInformation^ else
+ if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
+ begin
+ Result := False;
+ Exit;
+ end;
+
+ if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ llTime := PInt64(@ft)^;
+ if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ (* convert minutes to 100-nanoseconds-ticks *)
+ dec(llTime, Int64(lBias) * 600000000);
+ PInt64(@ft)^ := llTime;
+ Result := FileTimeToSystemTime(ft, lpLocalTime^);
+end;
+
+function TzSpecificLocalTimeToSystemTime(
+ const lpTimeZoneInformation: PTimeZoneInformation;
+ const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL;
+var
+ ft: TFileTime;
+ lBias: LongInt;
+ t: Int64;
+ tzinfo: TTimeZoneInformation;
+begin
+ if (lpTimeZoneInformation <> nil) then
+ tzinfo := lpTimeZoneInformation^
+ else
+ if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
+ begin
+ Result := False;
+ Exit;
+ end;
+
+ if (not SystemTimeToFileTime(lpLocalTime^, ft)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ t := PInt64(@ft)^;
+ if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ (* convert minutes to 100-nanoseconds-ticks *)
+ inc(t, Int64(lBias) * 600000000);
+ PInt64(@ft)^ := t;
+ Result := FileTimeToSystemTime(ft, lpUniversalTime^);
+end;
+{$ELSE}
+function TzSpecificLocalTimeToSystemTime(
+ lpTimeZoneInformation: PTimeZoneInformation;
+ lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
+
+function SystemTimeToTzSpecificLocalTime(
+ lpTimeZoneInformation: PTimeZoneInformation;
+ lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
+{$ENDIF}
+
+function JavaToDelphiDateTime(const dt: int64): TDateTime;
+var
+ t: TSystemTime;
+begin
+ DateTimeToSystemTime(25569 + (dt / 86400000), t);
+ SystemTimeToTzSpecificLocalTime(nil, @t, @t);
+ Result := SystemTimeToDateTime(t);
+end;
+
+function DelphiToJavaDateTime(const dt: TDateTime): int64;
+var
+ t: TSystemTime;
+begin
+ DateTimeToSystemTime(dt, t);
+ TzSpecificLocalTimeToSystemTime(nil, @t, @t);
+ Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000)
+end;
+{$ENDIF}
+
+
+function SO(const s: SOString): ISuperObject; overload;
+begin
+ Result := TSuperObject.ParseString(PSOChar(s), False);
+end;
+
+function SA(const Args: array of const): ISuperObject; overload;
+type
+ TByteArray = array[0..sizeof(integer) - 1] of byte;
+ PByteArray = ^TByteArray;
+var
+ j: Integer;
+ intf: IInterface;
+begin
+ Result := TSuperObject.Create(stArray);
+ for j := 0 to length(Args) - 1 do
+ with Result.AsArray do
+ case TVarRec(Args[j]).VType of
+ vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger));
+ vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^));
+ vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean));
+ vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar)));
+ vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar)));
+ vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^));
+ vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^));
+ vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^)));
+ vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^)));
+ vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString))));
+ vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString))));
+ vtInterface:
+ if TVarRec(Args[j]).VInterface = nil then
+ Add(nil) else
+ if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then
+ Add(ISuperObject(intf)) else
+ Add(nil);
+ vtPointer :
+ if TVarRec(Args[j]).VPointer = nil then
+ Add(nil) else
+ Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
+ vtVariant:
+ Add(SO(TVarRec(Args[j]).VVariant^));
+ vtObject:
+ if TVarRec(Args[j]).VPointer = nil then
+ Add(nil) else
+ Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
+ vtClass:
+ if TVarRec(Args[j]).VPointer = nil then
+ Add(nil) else
+ Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
+{$if declared(vtUnicodeString)}
+ vtUnicodeString:
+ Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString))));
+{$ifend}
+ else
+ assert(false);
+ end;
+end;
+
+function SO(const Args: array of const): ISuperObject; overload;
+var
+ j: Integer;
+ arr: ISuperObject;
+begin
+ Result := TSuperObject.Create(stObject);
+ arr := SA(Args);
+ with arr.AsArray do
+ for j := 0 to (Length div 2) - 1 do
+ Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]);
+end;
+
+function SO(const value: Variant): ISuperObject; overload;
+begin
+ with TVarData(value) do
+ case VType of
+ varNull: Result := nil;
+ varEmpty: Result := nil;
+ varSmallInt: Result := TSuperObject.Create(VSmallInt);
+ varInteger: Result := TSuperObject.Create(VInteger);
+ varSingle: Result := TSuperObject.Create(VSingle);
+ varDouble: Result := TSuperObject.Create(VDouble);
+ varCurrency: Result := TSuperObject.CreateCurrency(VCurrency);
+ varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate));
+ varOleStr: Result := TSuperObject.Create(SOString(VOleStr));
+ varBoolean: Result := TSuperObject.Create(VBoolean);
+ varShortInt: Result := TSuperObject.Create(VShortInt);
+ varByte: Result := TSuperObject.Create(VByte);
+ varWord: Result := TSuperObject.Create(VWord);
+ varLongWord: Result := TSuperObject.Create(VLongWord);
+ varInt64: Result := TSuperObject.Create(VInt64);
+ varString: Result := TSuperObject.Create(SOString(AnsiString(VString)));
+{$if declared(varUString)}
+ varUString: Result := TSuperObject.Create(SOString(string(VUString)));
+{$ifend}
+ else
+ raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]);
+ end;
+end;
+
+function ObjectIsError(obj: TSuperObject): boolean;
+begin
+ Result := PtrUInt(obj) > PtrUInt(-4000);
+end;
+
+function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
+begin
+ if obj <> nil then
+ Result := typ = obj.DataType else
+ Result := typ = stNull;
+end;
+
+function ObjectGetType(const obj: ISuperObject): TSuperType;
+begin
+ if obj <> nil then
+ Result := obj.DataType else
+ Result := stNull;
+end;
+
+function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
+var
+ i: TSuperAvlEntry;
+begin
+ if ObjectIsType(obj, stObject) then
+ begin
+ F.Ite := TSuperAvlIterator.Create(obj.AsObject);
+ F.Ite.First;
+ i := F.Ite.GetIter;
+ if i <> nil then
+ begin
+ f.key := i.Name;
+ f.val := i.Value;
+ Result := true;
+ end else
+ Result := False;
+ end else
+ Result := False;
+end;
+
+function ObjectFindNext(var F: TSuperObjectIter): boolean;
+var
+ i: TSuperAvlEntry;
+begin
+ F.Ite.Next;
+ i := F.Ite.GetIter;
+ if i <> nil then
+ begin
+ f.key := i.FName;
+ f.val := i.Value;
+ Result := true;
+ end else
+ Result := False;
+end;
+
+procedure ObjectFindClose(var F: TSuperObjectIter);
+begin
+ F.Ite.Free;
+ F.val := nil;
+end;
+
+{$IFDEF VER210}
+
+function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+begin
+ Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0);
+end;
+
+function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+begin
+ Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble));
+end;
+
+function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+var
+ g: TGUID;
+begin
+ value.ExtractRawData(@g);
+ Result := TSuperObject.Create(
+ format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x',
+ [g.D1, g.D2, g.D3,
+ g.D4[0], g.D4[1], g.D4[2],
+ g.D4[3], g.D4[4], g.D4[5],
+ g.D4[6], g.D4[7]])
+ );
+end;
+
+function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+var
+ o: ISuperObject;
+begin
+ case ObjectGetType(obj) of
+ stBoolean:
+ begin
+ TValueData(Value).FAsSLong := obj.AsInteger;
+ Result := True;
+ end;
+ stInt:
+ begin
+ TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0);
+ Result := True;
+ end;
+ stString:
+ begin
+ o := SO(obj.AsString);
+ if not ObjectIsType(o, stString) then
+ Result := serialfromboolean(ctx, SO(obj.AsString), Value) else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+end;
+
+function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+var
+ dt: TDateTime;
+begin
+ case ObjectGetType(obj) of
+ stInt:
+ begin
+ TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger);
+ Result := True;
+ end;
+ stString:
+ begin
+ if TryStrToDateTime(obj.AsString, dt) then
+ begin
+ TValueData(Value).FAsDouble := dt;
+ Result := True;
+ end else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+end;
+
+function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean;
+const
+ hex2bin: array[#0..#102] of short = (
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x00 *)
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x10 *)
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x20 *)
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, (* 0x30 *)
+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x40 *)
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x50 *)
+ -1,10,11,12,13,14,15); (* 0x60 *)
+var
+ i: Integer;
+begin
+ if (strlen(s) <> 36) then Exit(False);
+
+ if ((s[8] <> '-') or (s[13] <> '-') or (s[18] <> '-') or (s[23] <> '-')) then
+ Exit(False);
+
+ for i := 0 to 35 do
+ begin
+ if not i in [8,13,18,23] then
+ if ((s[i] > 'f') or ((hex2bin[s[i]] = -1) and (s[i] <> ''))) then
+ Exit(False);
+ end;
+
+ 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
+ (hex2bin[s[4]] shl 12) or (hex2bin[s[5]] shl 8) or (hex2bin[s[6]] shl 4) or hex2bin[s[7]]);
+ uuid.D2 := (hex2bin[s[9]] shl 12) or (hex2bin[s[10]] shl 8) or (hex2bin[s[11]] shl 4) or hex2bin[s[12]];
+ uuid.D3 := (hex2bin[s[14]] shl 12) or (hex2bin[s[15]] shl 8) or (hex2bin[s[16]] shl 4) or hex2bin[s[17]];
+
+ uuid.D4[0] := (hex2bin[s[19]] shl 4) or hex2bin[s[20]];
+ uuid.D4[1] := (hex2bin[s[21]] shl 4) or hex2bin[s[22]];
+ uuid.D4[2] := (hex2bin[s[24]] shl 4) or hex2bin[s[25]];
+ uuid.D4[3] := (hex2bin[s[26]] shl 4) or hex2bin[s[27]];
+ uuid.D4[4] := (hex2bin[s[28]] shl 4) or hex2bin[s[29]];
+ uuid.D4[5] := (hex2bin[s[30]] shl 4) or hex2bin[s[31]];
+ uuid.D4[6] := (hex2bin[s[32]] shl 4) or hex2bin[s[33]];
+ uuid.D4[7] := (hex2bin[s[34]] shl 4) or hex2bin[s[35]];
+ Result := True;
+end;
+
+function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+begin
+ case ObjectGetType(obj) of
+ stNull:
+ begin
+ FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0);
+ Result := True;
+ end;
+ stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData);
+ else
+ Result := False;
+ end;
+end;
+
+function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload;
+var
+ owned: Boolean;
+begin
+ if ctx = nil then
+ begin
+ ctx := TSuperRttiContext.Create;
+ owned := True;
+ end else
+ owned := False;
+ try
+ if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then
+ raise Exception.Create('Invalid method call');
+ finally
+ if owned then
+ ctx.Free;
+ end;
+end;
+
+function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload;
+begin
+ Result := SOInvoke(obj, method, so(params), ctx)
+end;
+
+function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue;
+ const method: string; const params: ISuperObject;
+ var Return: ISuperObject): TSuperInvokeResult;
+var
+ t: TRttiInstanceType;
+ m: TRttiMethod;
+ a: TArray;
+ ps: TArray;
+ v: TValue;
+ index: ISuperObject;
+
+ function GetParams: Boolean;
+ var
+ i: Integer;
+ begin
+ case ObjectGetType(params) of
+ stArray:
+ for i := 0 to Length(ps) - 1 do
+ if (pfOut in ps[i].Flags) then
+ TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
+ if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then
+ Exit(False);
+ stObject:
+ for i := 0 to Length(ps) - 1 do
+ if (pfOut in ps[i].Flags) then
+ TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
+ if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then
+ Exit(False);
+ stNull: ;
+ else
+ Exit(False);
+ end;
+ Result := True;
+ end;
+
+ procedure SetParams;
+ var
+ i: Integer;
+ begin
+ case ObjectGetType(params) of
+ stArray:
+ for i := 0 to Length(ps) - 1 do
+ if (ps[i].Flags * [pfVar, pfOut]) <> [] then
+ params.AsArray[i] := ctx.ToJson(a[i], index);
+ stObject:
+ for i := 0 to Length(ps) - 1 do
+ if (ps[i].Flags * [pfVar, pfOut]) <> [] then
+ params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index);
+ end;
+ end;
+
+begin
+ Result := irSuccess;
+ index := SO;
+ case obj.Kind of
+ tkClass:
+ begin
+ t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType));
+ m := t.GetMethod(method);
+ if m = nil then Exit(irMethothodError);
+ ps := m.GetParameters;
+ SetLength(a, Length(ps));
+ if not GetParams then Exit(irParamError);
+ if m.IsClassMethod then
+ begin
+ v := m.Invoke(obj.AsObject.ClassType, a);
+ Return := ctx.ToJson(v, index);
+ SetParams;
+ end else
+ begin
+ v := m.Invoke(obj, a);
+ Return := ctx.ToJson(v, index);
+ SetParams;
+ end;
+ end;
+ tkClassRef:
+ begin
+ t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass));
+ m := t.GetMethod(method);
+ if m = nil then Exit(irMethothodError);
+ ps := m.GetParameters;
+ SetLength(a, Length(ps));
+
+ if not GetParams then Exit(irParamError);
+ if m.IsClassMethod then
+ begin
+ v := m.Invoke(obj, a);
+ Return := ctx.ToJson(v, index);
+ SetParams;
+ end else
+ Exit(irError);
+ end;
+ else
+ Exit(irError);
+ end;
+end;
+
+{$ENDIF}
+
+{ TSuperEnumerator }
+
+constructor TSuperEnumerator.Create(const obj: ISuperObject);
+begin
+ FObj := obj;
+ FCount := -1;
+ if ObjectIsType(FObj, stObject) then
+ FObjEnum := FObj.AsObject.GetEnumerator else
+ FObjEnum := nil;
+end;
+
+destructor TSuperEnumerator.Destroy;
+begin
+ if FObjEnum <> nil then
+ FObjEnum.Free;
+end;
+
+function TSuperEnumerator.MoveNext: Boolean;
+begin
+ case ObjectGetType(FObj) of
+ stObject: Result := FObjEnum.MoveNext;
+ stArray:
+ begin
+ inc(FCount);
+ if FCount < FObj.AsArray.Length then
+ Result := True else
+ Result := False;
+ end;
+ else
+ Result := false;
+ end;
+end;
+
+function TSuperEnumerator.GetCurrent: ISuperObject;
+begin
+ case ObjectGetType(FObj) of
+ stObject: Result := FObjEnum.Current.Value;
+ stArray: Result := FObj.AsArray.GetO(FCount);
+ else
+ Result := FObj;
+ end;
+end;
+
+{ TSuperObject }
+
+constructor TSuperObject.Create(jt: TSuperType);
+begin
+ inherited Create;
+{$IFDEF DEBUG}
+ InterlockedIncrement(debugcount);
+{$ENDIF}
+
+ FProcessing := false;
+ FDataPtr := nil;
+ FDataType := jt;
+ case FDataType of
+ stObject: FO.c_object := TSuperTableString.Create;
+ stArray: FO.c_array := TSuperArray.Create;
+ stString: FOString := '';
+ else
+ FO.c_object := nil;
+ end;
+end;
+
+constructor TSuperObject.Create(b: boolean);
+begin
+ Create(stBoolean);
+ FO.c_boolean := b;
+end;
+
+constructor TSuperObject.Create(i: SuperInt);
+begin
+ Create(stInt);
+ FO.c_int := i;
+end;
+
+constructor TSuperObject.Create(d: double);
+begin
+ Create(stDouble);
+ FO.c_double := d;
+end;
+
+constructor TSuperObject.CreateCurrency(c: Currency);
+begin
+ Create(stCurrency);
+ FO.c_currency := c;
+end;
+
+destructor TSuperObject.Destroy;
+begin
+{$IFDEF DEBUG}
+ InterlockedDecrement(debugcount);
+{$ENDIF}
+ case FDataType of
+ stObject: FO.c_object.Free;
+ stArray: FO.c_array.Free;
+ end;
+ inherited;
+end;
+
+function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
+function DoEscape(str: PSOChar; len: Integer): Integer;
+var
+ pos, start_offset: Integer;
+ c: SOChar;
+ buf: array[0..5] of SOChar;
+type
+ TByteChar = record
+ case integer of
+ 0: (a, b: Byte);
+ 1: (c: WideChar);
+ end;
+ begin
+ if str = nil then
+ begin
+ Result := 0;
+ exit;
+ end;
+ pos := 0; start_offset := 0;
+ with writer do
+ while pos < len do
+ begin
+ c := str[pos];
+ case c of
+ #8,#9,#10,#12,#13,'"','\','/':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+
+ if(c = #8) then Append(ESC_BS, 2)
+ else if (c = #9) then Append(ESC_TAB, 2)
+ else if (c = #10) then Append(ESC_LF, 2)
+ else if (c = #12) then Append(ESC_FF, 2)
+ else if (c = #13) then Append(ESC_CR, 2)
+ else if (c = '"') then Append(ESC_QUOT, 2)
+ else if (c = '\') then Append(ESC_SL, 2)
+ else if (c = '/') then Append(ESC_SR, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ else
+ if (SOIChar(c) > 255) then
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ buf[0] := '\';
+ buf[1] := 'u';
+ buf[2] := super_hex_chars[TByteChar(c).b shr 4];
+ buf[3] := super_hex_chars[TByteChar(c).b and $f];
+ buf[4] := super_hex_chars[TByteChar(c).a shr 4];
+ buf[5] := super_hex_chars[TByteChar(c).a and $f];
+ Append(@buf, 6);
+ inc(pos);
+ start_offset := pos;
+ end else
+ if (c < #32) or (c > #127) then
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ buf[0] := '\';
+ buf[1] := 'u';
+ buf[2] := '0';
+ buf[3] := '0';
+ buf[4] := super_hex_chars[ord(c) shr 4];
+ buf[5] := super_hex_chars[ord(c) and $f];
+ Append(buf, 6);
+ inc(pos);
+ start_offset := pos;
+ end else
+ inc(pos);
+ end;
+ end;
+ if(pos - start_offset > 0) then
+ writer.Append(str + start_offset, pos - start_offset);
+ Result := 0;
+ end;
+
+function DoMinimalEscape(str: PSOChar; len: Integer): Integer;
+var
+ pos, start_offset: Integer;
+ c: SOChar;
+type
+ TByteChar = record
+ case integer of
+ 0: (a, b: Byte);
+ 1: (c: WideChar);
+ end;
+ begin
+ if str = nil then
+ begin
+ Result := 0;
+ exit;
+ end;
+ pos := 0; start_offset := 0;
+ with writer do
+ while pos < len do
+ begin
+ c := str[pos];
+ case c of
+ #0:
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_ZERO, 6);
+ inc(pos);
+ start_offset := pos;
+ end;
+ '"':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_QUOT, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ '\':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_SL, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ '/':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_SR, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ else
+ inc(pos);
+ end;
+ end;
+ if(pos - start_offset > 0) then
+ writer.Append(str + start_offset, pos - start_offset);
+ Result := 0;
+ end;
+
+
+ procedure _indent(i: shortint; r: boolean);
+ begin
+ inc(level, i);
+ if r then
+ with writer do
+ begin
+{$IFDEF MSWINDOWS}
+ Append(TOK_CRLF, 2);
+{$ELSE}
+ Append(TOK_LF, 1);
+{$ENDIF}
+ for i := 0 to level - 1 do
+ Append(TOK_SP, 1);
+ end;
+ end;
+var
+ k,j: Integer;
+ iter: TSuperObjectIter;
+ st: AnsiString;
+ val: ISuperObject;
+ fbuffer: array[0..31] of AnsiChar;
+const
+ ENDSTR_A: PSOChar = '": ';
+ ENDSTR_B: PSOChar = '":';
+begin
+
+ if FProcessing then
+ begin
+ Result := writer.Append(TOK_NULL, 4);
+ Exit;
+ end;
+
+ FProcessing := true;
+ with writer do
+ try
+ case FDataType of
+ stObject:
+ if FO.c_object.FCount > 0 then
+ begin
+ k := 0;
+ Append(TOK_CBL, 1);
+ if indent then _indent(1, false);
+ if ObjectFindFirst(Self, iter) then
+ repeat
+ {$IFDEF SUPER_METHOD}
+ if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then
+ begin
+ {$ENDIF}
+ if (iter.val = nil) or (not iter.val.Processing) then
+ begin
+ if(k <> 0) then
+ Append(TOK_COM, 1);
+ if indent then _indent(0, true);
+ Append(TOK_DQT, 1);
+ if escape then
+ doEscape(PSOChar(iter.key), Length(iter.key)) else
+ DoMinimalEscape(PSOChar(iter.key), Length(iter.key));
+ if indent then
+ Append(ENDSTR_A, 3) else
+ Append(ENDSTR_B, 2);
+ if(iter.val = nil) then
+ Append(TOK_NULL, 4) else
+ iter.val.write(writer, indent, escape, level);
+ inc(k);
+ end;
+ {$IFDEF SUPER_METHOD}
+ end;
+ {$ENDIF}
+ until not ObjectFindNext(iter);
+ ObjectFindClose(iter);
+ if indent then _indent(-1, true);
+ Result := Append(TOK_CBR, 1);
+ end else
+ Result := Append(TOK_OBJ, 2);
+ stBoolean:
+ begin
+ if (FO.c_boolean) then
+ Result := Append(TOK_TRUE, 4) else
+ Result := Append(TOK_FALSE, 5);
+ end;
+ stInt:
+ begin
+ str(FO.c_int, st);
+ Result := Append(PSOChar(SOString(st)));
+ end;
+ stDouble:
+ Result := Append(PSOChar(SOString(gcvt(FO.c_double, 15, fbuffer))));
+ stCurrency:
+ begin
+ Result := Append(PSOChar(CurrToStr(FO.c_currency)));
+ end;
+ stString:
+ begin
+ Append(TOK_DQT, 1);
+ if escape then
+ doEscape(PSOChar(FOString), Length(FOString)) else
+ DoMinimalEscape(PSOChar(FOString), Length(FOString));
+ Append(TOK_DQT, 1);
+ Result := 0;
+ end;
+ stArray:
+ if FO.c_array.FLength > 0 then
+ begin
+ Append(TOK_ARL, 1);
+ if indent then _indent(1, true);
+ k := 0;
+ j := 0;
+ while k < FO.c_array.FLength do
+ begin
+
+ val := FO.c_array.GetO(k);
+ {$IFDEF SUPER_METHOD}
+ if not ObjectIsType(val, stMethod) then
+ begin
+ {$ENDIF}
+ if (val = nil) or (not val.Processing) then
+ begin
+ if (j <> 0) then
+ Append(TOK_COM, 1);
+ if(val = nil) then
+ Append(TOK_NULL, 4) else
+ val.write(writer, indent, escape, level);
+ inc(j);
+ end;
+ {$IFDEF SUPER_METHOD}
+ end;
+ {$ENDIF}
+ inc(k);
+ end;
+ if indent then _indent(-1, false);
+ Result := Append(TOK_ARR, 1);
+ end else
+ Result := Append(TOK_ARRAY, 2);
+ stNull:
+ Result := Append(TOK_NULL, 4);
+ else
+ Result := 0;
+ end;
+ finally
+ FProcessing := false;
+ end;
+end;
+
+function TSuperObject.IsType(AType: TSuperType): boolean;
+begin
+ Result := AType = FDataType;
+end;
+
+function TSuperObject.AsBoolean: boolean;
+begin
+ case FDataType of
+ stBoolean: Result := FO.c_boolean;
+ stInt: Result := (FO.c_int <> 0);
+ stDouble: Result := (FO.c_double <> 0);
+ stCurrency: Result := (FO.c_currency <> 0);
+ stString: Result := (Length(FOString) <> 0);
+ stNull: Result := False;
+ else
+ Result := True;
+ end;
+end;
+
+function TSuperObject.AsInteger: SuperInt;
+var
+ code: integer;
+ cint: SuperInt;
+begin
+ case FDataType of
+ stInt: Result := FO.c_int;
+ stDouble: Result := round(FO.c_double);
+ stCurrency: Result := round(FO.c_currency);
+ stBoolean: Result := ord(FO.c_boolean);
+ stString:
+ begin
+ Val(FOString, cint, code);
+ if code = 0 then
+ Result := cint else
+ Result := 0;
+ end;
+ else
+ Result := 0;
+ end;
+end;
+
+function TSuperObject.AsDouble: Double;
+var
+ code: integer;
+ cdouble: double;
+begin
+ case FDataType of
+ stDouble: Result := FO.c_double;
+ stCurrency: Result := FO.c_currency;
+ stInt: Result := FO.c_int;
+ stBoolean: Result := ord(FO.c_boolean);
+ stString:
+ begin
+ Val(FOString, cdouble, code);
+ if code = 0 then
+ Result := cdouble else
+ Result := 0.0;
+ end;
+ else
+ Result := 0.0;
+ end;
+end;
+
+function TSuperObject.AsCurrency: Currency;
+var
+ code: integer;
+ cdouble: double;
+begin
+ case FDataType of
+ stDouble: Result := FO.c_double;
+ stCurrency: Result := FO.c_currency;
+ stInt: Result := FO.c_int;
+ stBoolean: Result := ord(FO.c_boolean);
+ stString:
+ begin
+ Val(FOString, cdouble, code);
+ if code = 0 then
+ Result := cdouble else
+ Result := 0.0;
+ end;
+ else
+ Result := 0.0;
+ end;
+end;
+
+function TSuperObject.AsString: SOString;
+begin
+ if FDataType = stString then
+ Result := FOString else
+ Result := AsJSon(false, false);
+end;
+
+function TSuperObject.GetEnumerator: TSuperEnumerator;
+begin
+ Result := TSuperEnumerator.Create(Self);
+end;
+
+procedure TSuperObject.AfterConstruction;
+begin
+ InterlockedDecrement(FRefCount);
+end;
+
+procedure TSuperObject.BeforeDestruction;
+begin
+ if RefCount <> 0 then
+ raise Exception.Create('Invalid pointer');
+end;
+
+function TSuperObject.AsArray: TSuperArray;
+begin
+ if FDataType = stArray then
+ Result := FO.c_array else
+ Result := nil;
+end;
+
+function TSuperObject.AsObject: TSuperTableString;
+begin
+ if FDataType = stObject then
+ Result := FO.c_object else
+ Result := nil;
+end;
+
+function TSuperObject.AsJSon(indent, escape: boolean): SOString;
+var
+ pb: TSuperWriterString;
+begin
+ pb := TSuperWriterString.Create;
+ try
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ Result := '';
+ Exit;
+ end;
+ if pb.FBPos > 0 then
+ Result := pb.FBuf else
+ Result := '';
+ finally
+ pb.Free;
+ end;
+end;
+
+class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject;
+ options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
+var
+ tok: TSuperTokenizer;
+ obj: ISuperObject;
+begin
+ tok := TSuperTokenizer.Create;
+ obj := ParseEx(tok, s, -1, strict, this, options, put, dt);
+ if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then
+ Result := nil else
+ Result := obj;
+ tok.Free;
+end;
+
+class function TSuperObject.ParseStream(stream: TStream; strict: Boolean;
+ partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
+ const put: ISuperObject; dt: TSuperType): ISuperObject;
+const
+ BUFFER_SIZE = 1024;
+var
+ tok: TSuperTokenizer;
+ buffera: array[0..BUFFER_SIZE-1] of AnsiChar;
+ bufferw: array[0..BUFFER_SIZE-1] of SOChar;
+ bom: array[0..1] of byte;
+ unicode: boolean;
+ j, size: Integer;
+ st: string;
+begin
+ st := '';
+ tok := TSuperTokenizer.Create;
+
+ if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then
+ begin
+ unicode := true;
+ size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
+ end else
+ begin
+ unicode := false;
+ stream.Seek(0, soFromBeginning);
+ size := stream.Read(buffera, BUFFER_SIZE);
+ end;
+
+ while size > 0 do
+ begin
+ if not unicode then
+ for j := 0 to size - 1 do
+ bufferw[j] := SOChar(buffera[j]);
+ ParseEx(tok, bufferw, size, strict, this, options, put, dt);
+
+ if tok.err = teContinue then
+ begin
+ if not unicode then
+ size := stream.Read(buffera, BUFFER_SIZE) else
+ size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
+ end else
+ Break;
+ end;
+ if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then
+ Result := nil else
+ Result := tok.stack[tok.depth].current;
+ tok.Free;
+end;
+
+class function TSuperObject.ParseFile(const FileName: string; strict: Boolean;
+ partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
+ const put: ISuperObject; dt: TSuperType): ISuperObject;
+var
+ stream: TFileStream;
+begin
+ stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite);
+ try
+ Result := ParseStream(stream, strict, partial, this, options, put, dt);
+ finally
+ stream.Free;
+ end;
+end;
+
+class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer;
+ strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
+
+const
+ spaces = [#32,#8,#9,#10,#12,#13];
+ delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0];
+ reserved = delimiters + spaces;
+ path = ['a'..'z', 'A'..'Z', '.', '_'];
+
+ function hexdigit(x: SOChar): byte;
+ begin
+ if x <= '9' then
+ Result := byte(x) - byte('0') else
+ Result := (byte(x) and 7) + 9;
+ end;
+ function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end;
+
+var
+ obj: ISuperObject;
+ v: SOChar;
+{$IFDEF SUPER_METHOD}
+ sm: TSuperMethod;
+{$ENDIF}
+ numi: SuperInt;
+ numd: Double;
+ code: integer;
+ TokRec: PSuperTokenerSrec;
+ evalstack: integer;
+ p: PSOChar;
+
+ function IsEndDelimiter(v: AnsiChar): Boolean;
+ begin
+ if tok.depth > 0 then
+ case tok.stack[tok.depth - 1].state of
+ tsArrayAdd: Result := v in [',', ']', #0];
+ tsObjectValueAdd: Result := v in [',', '}', #0];
+ else
+ Result := v = #0;
+ end else
+ Result := v = #0;
+ end;
+
+label out, redo_char;
+begin
+ evalstack := 0;
+ obj := nil;
+ Result := nil;
+ TokRec := @tok.stack[tok.depth];
+
+ tok.char_offset := 0;
+ tok.err := teSuccess;
+
+ repeat
+ if (tok.char_offset = len) then
+ begin
+ if (tok.depth = 0) and (TokRec^.state = tsEatws) and
+ (TokRec^.saved_state = tsFinish) then
+ tok.err := teSuccess else
+ tok.err := teContinue;
+ goto out;
+ end;
+
+ v := str^;
+
+ case v of
+ #10:
+ begin
+ inc(tok.line);
+ tok.col := 0;
+ end;
+ #9: inc(tok.col, 4);
+ else
+ inc(tok.col);
+ end;
+
+redo_char:
+ case TokRec^.state of
+ tsEatws:
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else
+ if (v = '/') then
+ begin
+ tok.pb.Reset;
+ tok.pb.Append(@v, 1);
+ TokRec^.state := tsCommentStart;
+ end else begin
+ TokRec^.state := TokRec^.saved_state;
+ goto redo_char;
+ end
+ end;
+
+ tsStart:
+ case v of
+ '"',
+ '''':
+ begin
+ TokRec^.state := tsString;
+ tok.pb.Reset;
+ tok.quote_char := v;
+ end;
+ '-':
+ begin
+ TokRec^.state := tsNumber;
+ tok.pb.Reset;
+ tok.is_double := 0;
+ tok.floatcount := -1;
+ goto redo_char;
+ end;
+
+ '0'..'9':
+ begin
+ if (tok.depth = 0) then
+ case ObjectGetType(this) of
+ stObject:
+ begin
+ TokRec^.state := tsIdentifier;
+ TokRec^.current := this;
+ goto redo_char;
+ end;
+ end;
+ TokRec^.state := tsNumber;
+ tok.pb.Reset;
+ tok.is_double := 0;
+ tok.floatcount := -1;
+ goto redo_char;
+ end;
+ '{':
+ begin
+ TokRec^.state := tsEatws;
+ TokRec^.saved_state := tsObjectFieldStart;
+ TokRec^.current := TSuperObject.Create(stObject);
+ end;
+ '[':
+ begin
+ TokRec^.state := tsEatws;
+ TokRec^.saved_state := tsArray;
+ TokRec^.current := TSuperObject.Create(stArray);
+ end;
+{$IFDEF SUPER_METHOD}
+ '(':
+ begin
+ if (tok.depth = 0) and ObjectIsType(this, stMethod) then
+ begin
+ TokRec^.current := this;
+ TokRec^.state := tsParamValue;
+ end;
+ end;
+{$ENDIF}
+ 'N',
+ 'n':
+ begin
+ TokRec^.state := tsNull;
+ tok.pb.Reset;
+ tok.st_pos := 0;
+ goto redo_char;
+ end;
+ 'T',
+ 't',
+ 'F',
+ 'f':
+ begin
+ TokRec^.state := tsBoolean;
+ tok.pb.Reset;
+ tok.st_pos := 0;
+ goto redo_char;
+ end;
+ else
+ TokRec^.state := tsIdentifier;
+ tok.pb.Reset;
+ goto redo_char;
+ end;
+
+ tsFinish:
+ begin
+ if(tok.depth = 0) then goto out;
+ obj := TokRec^.current;
+ tok.ResetLevel(tok.depth);
+ dec(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+
+ tsNull:
+ begin
+ tok.pb.Append(@v, 1);
+ if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
+ begin
+ if (tok.st_pos = 4) then
+ if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
+ TokRec^.state := tsIdentifier else
+ begin
+ TokRec^.current := TSuperObject.Create(stNull);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end;
+ end else
+ begin
+ TokRec^.state := tsIdentifier;
+ tok.pb.FBuf[tok.st_pos] := #0;
+ dec(tok.pb.FBPos);
+ goto redo_char;
+ end;
+ inc(tok.st_pos);
+ end;
+
+ tsCommentStart:
+ begin
+ if(v = '*') then
+ begin
+ TokRec^.state := tsComment;
+ end else
+ if (v = '/') then
+ begin
+ TokRec^.state := tsCommentEol;
+ end else
+ begin
+ tok.err := teParseComment;
+ goto out;
+ end;
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsComment:
+ begin
+ if(v = '*') then
+ TokRec^.state := tsCommentEnd;
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsCommentEol:
+ begin
+ if (v = #10) then
+ TokRec^.state := tsEatws else
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsCommentEnd:
+ begin
+ tok.pb.Append(@v, 1);
+ if (v = '/') then
+ TokRec^.state := tsEatws else
+ TokRec^.state := tsComment;
+ end;
+
+ tsString:
+ begin
+ if (v = tok.quote_char) then
+ begin
+ TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString));
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsString;
+ TokRec^.state := tsStringEscape;
+ end else
+ begin
+ tok.pb.Append(@v, 1);
+ end
+ end;
+
+ tsEvalProperty:
+ begin
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stObject);
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
+ end else
+ if not ObjectIsType(TokRec^.current, stObject) then
+ begin
+ tok.err := teEvalObject;
+ goto out;
+ end;
+ tok.pb.Reset;
+ TokRec^.state := tsIdentifier;
+ goto redo_char;
+ end;
+
+ tsEvalArray:
+ begin
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stArray);
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
+ end else
+ if not ObjectIsType(TokRec^.current, stArray) then
+ begin
+ tok.err := teEvalArray;
+ goto out;
+ end;
+ tok.pb.Reset;
+ TokRec^.state := tsParamValue;
+ goto redo_char;
+ end;
+{$IFDEF SUPER_METHOD}
+ tsEvalMethod:
+ begin
+ if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
+ begin
+ tok.pb.Reset;
+ TokRec^.obj := TSuperObject.Create(stArray);
+ TokRec^.state := tsMethodValue;
+ goto redo_char;
+ end else
+ begin
+ tok.err := teEvalMethod;
+ goto out;
+ end;
+ end;
+
+ tsMethodValue:
+ begin
+ case v of
+ ')':
+ TokRec^.state := tsIdentifier;
+ else
+ if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ inc(evalstack);
+ TokRec^.state := tsMethodPut;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+ end;
+
+ tsMethodPut:
+ begin
+ TokRec^.obj.AsArray.Add(obj);
+ case v of
+ ',':
+ begin
+ tok.pb.Reset;
+ TokRec^.saved_state := tsMethodValue;
+ TokRec^.state := tsEatws;
+ end;
+ ')':
+ begin
+ if TokRec^.obj.AsArray.Length = 1 then
+ TokRec^.obj := TokRec^.obj.AsArray.GetO(0);
+ dec(evalstack);
+ tok.pb.Reset;
+ TokRec^.saved_state := tsIdentifier;
+ TokRec^.state := tsEatws;
+ end;
+ else
+ tok.err := teEvalMethod;
+ goto out;
+ end;
+ end;
+{$ENDIF}
+ tsParamValue:
+ begin
+ case v of
+ ']':
+ TokRec^.state := tsIdentifier;
+ else
+ if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ inc(evalstack);
+ TokRec^.state := tsParamPut;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+ end;
+
+ tsParamPut:
+ begin
+ dec(evalstack);
+ TokRec^.obj := obj;
+ tok.pb.Reset;
+ TokRec^.saved_state := tsIdentifier;
+ TokRec^.state := tsEatws;
+ if v <> ']' then
+ begin
+ tok.err := teEvalArray;
+ goto out;
+ end;
+ end;
+
+ tsIdentifier:
+ begin
+ if (this = nil) then
+ begin
+ if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then
+ begin
+ if not strict then
+ begin
+ tok.pb.TrimRight;
+ TokRec^.current := TSuperObject.Create(tok.pb.Fbuf);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end else
+ begin
+ tok.err := teParseString;
+ goto out;
+ end;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsIdentifier;
+ TokRec^.state := tsStringEscape;
+ end else
+ tok.pb.Append(@v, 1);
+ end else
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then
+ begin
+ TokRec^.gparent := TokRec^.parent;
+ if TokRec^.current = nil then
+ TokRec^.parent := this else
+ TokRec^.parent := TokRec^.current;
+
+ case ObjectGetType(TokRec^.parent) of
+ stObject:
+ case v of
+ '.':
+ begin
+ TokRec^.state := tsEvalProperty;
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ end;
+ '[':
+ begin
+ TokRec^.state := tsEvalArray;
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ end;
+ '(':
+ begin
+ TokRec^.state := tsEvalMethod;
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ end;
+ else
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put);
+ TokRec^.current := put
+ end else
+ if (foDelete in options) and (evalstack = 0) then
+ begin
+ TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf);
+ end else
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(dt);
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current);
+ end;
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ TokRec^.state := tsFinish;
+ goto redo_char;
+ end;
+ stArray:
+ begin
+ if TokRec^.obj <> nil then
+ begin
+ if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then
+ begin
+ tok.err := teEvalInt;
+ TokRec^.obj := nil;
+ goto out;
+ end;
+ numi := TokRec^.obj.AsInteger;
+ TokRec^.obj := nil;
+
+ TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
+ case v of
+ '.':
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stObject);
+ TokRec^.parent.AsArray.PutO(numi, TokRec^.current);
+ end else
+ if (TokRec^.current = nil) then
+ begin
+ tok.err := teEvalObject;
+ goto out;
+ end;
+ '[':
+ begin
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stArray);
+ TokRec^.parent.AsArray.Add(TokRec^.current);
+ end else
+ if (TokRec^.current = nil) then
+ begin
+ tok.err := teEvalArray;
+ goto out;
+ end;
+ TokRec^.state := tsEvalArray;
+ end;
+ '(': TokRec^.state := tsEvalMethod;
+ else
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ TokRec^.parent.AsArray.PutO(numi, put);
+ TokRec^.current := put;
+ end else
+ if (foDelete in options) and (evalstack = 0) then
+ begin
+ TokRec^.current := TokRec^.parent.AsArray.Delete(numi);
+ end else
+ TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
+ TokRec^.state := tsFinish;
+ goto redo_char
+ end;
+ end else
+ begin
+ case v of
+ '.':
+ begin
+ if (foPutValue in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stObject);
+ TokRec^.parent.AsArray.Add(TokRec^.current);
+ end else
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
+ end;
+ '[':
+ begin
+ if (foPutValue in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stArray);
+ TokRec^.parent.AsArray.Add(TokRec^.current);
+ end else
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
+ TokRec^.state := tsEvalArray;
+ end;
+ '(':
+ begin
+ if not (foPutValue in options) then
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else
+ TokRec^.current := nil;
+
+ TokRec^.state := tsEvalMethod;
+ end;
+ else
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ TokRec^.parent.AsArray.Add(put);
+ TokRec^.current := put;
+ end else
+ if tok.pb.FBPos = 0 then
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
+ TokRec^.state := tsFinish;
+ goto redo_char
+ end;
+ end;
+ end;
+{$IFDEF SUPER_METHOD}
+ stMethod:
+ case v of
+ '.':
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.obj := nil;
+ end;
+ '[':
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.state := tsEvalArray;
+ TokRec^.obj := nil;
+ end;
+ '(':
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.state := tsEvalMethod;
+ TokRec^.obj := nil;
+ end;
+ else
+ if not (foPutValue in options) or (evalstack > 0) then
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.obj := nil;
+ TokRec^.state := tsFinish;
+ goto redo_char
+ end else
+ begin
+ tok.err := teEvalMethod;
+ TokRec^.obj := nil;
+ goto out;
+ end;
+ end;
+{$ENDIF}
+ end;
+ end else
+ tok.pb.Append(@v, 1);
+ end;
+ end;
+
+ tsStringEscape:
+ case v of
+ 'b',
+ 'n',
+ 'r',
+ 't',
+ 'f':
+ begin
+ if(v = 'b') then tok.pb.Append(TOK_BS, 1)
+ else if(v = 'n') then tok.pb.Append(TOK_LF, 1)
+ else if(v = 'r') then tok.pb.Append(TOK_CR, 1)
+ else if(v = 't') then tok.pb.Append(TOK_TAB, 1)
+ else if(v = 'f') then tok.pb.Append(TOK_FF, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end;
+ 'u':
+ begin
+ tok.ucs_char := 0;
+ tok.st_pos := 0;
+ TokRec^.state := tsEscapeUnicode;
+ end;
+ 'x':
+ begin
+ tok.ucs_char := 0;
+ tok.st_pos := 0;
+ TokRec^.state := tsEscapeHexadecimal;
+ end
+ else
+ tok.pb.Append(@v, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end;
+
+ tsEscapeUnicode:
+ begin
+ if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
+ begin
+ inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4)));
+ inc(tok.st_pos);
+ if (tok.st_pos = 4) then
+ begin
+ tok.pb.Append(@tok.ucs_char, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end
+ end else
+ begin
+ tok.err := teParseString;
+ goto out;
+ end
+ end;
+ tsEscapeHexadecimal:
+ begin
+ if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
+ begin
+ inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4)));
+ inc(tok.st_pos);
+ if (tok.st_pos = 2) then
+ begin
+ tok.pb.Append(@tok.ucs_char, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end
+ end else
+ begin
+ tok.err := teParseString;
+ goto out;
+ end
+ end;
+ tsBoolean:
+ begin
+ tok.pb.Append(@v, 1);
+ if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
+ begin
+ if (tok.st_pos = 4) then
+ if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
+ TokRec^.state := tsIdentifier else
+ begin
+ TokRec^.current := TSuperObject.Create(true);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end
+ end else
+ if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then
+ begin
+ if (tok.st_pos = 5) then
+ if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
+ TokRec^.state := tsIdentifier else
+ begin
+ TokRec^.current := TSuperObject.Create(false);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end
+ end else
+ begin
+ TokRec^.state := tsIdentifier;
+ tok.pb.FBuf[tok.st_pos] := #0;
+ dec(tok.pb.FBPos);
+ goto redo_char;
+ end;
+ inc(tok.st_pos);
+ end;
+
+ tsNumber:
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then
+ begin
+ tok.pb.Append(@v, 1);
+ if (SOIChar(v) < 256) then
+ case v of
+ '.': begin
+ tok.is_double := 1;
+ tok.floatcount := 0;
+ end;
+ 'e','E':
+ begin
+ tok.is_double := 1;
+ tok.floatcount := -1;
+ end;
+ '0'..'9':
+ begin
+
+ if (tok.is_double = 1) and (tok.floatcount >= 0) then
+ begin
+ inc(tok.floatcount);
+ if tok.floatcount > 4 then
+ tok.floatcount := -1;
+ end;
+ end;
+ end;
+ end else
+ begin
+ if (tok.is_double = 0) then
+ begin
+ val(tok.pb.FBuf, numi, code);
+ if ObjectIsType(this, stArray) then
+ begin
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ this.AsArray.PutO(numi, put);
+ TokRec^.current := put;
+ end else
+ if (foDelete in options) and (evalstack = 0) then
+ TokRec^.current := this.AsArray.Delete(numi) else
+ TokRec^.current := this.AsArray.GetO(numi);
+ end else
+ TokRec^.current := TSuperObject.Create(numi);
+
+ end else
+ if (tok.is_double <> 0) then
+ begin
+ if tok.floatcount >= 0 then
+ begin
+ p := tok.pb.FBuf;
+ while p^ <> '.' do inc(p);
+ for code := 0 to tok.floatcount - 1 do
+ begin
+ p^ := p[1];
+ inc(p);
+ end;
+ p^ := #0;
+ val(tok.pb.FBuf, numi, code);
+ case tok.floatcount of
+ 0: numi := numi * 10000;
+ 1: numi := numi * 1000;
+ 2: numi := numi * 100;
+ 3: numi := numi * 10;
+ end;
+ TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^);
+ end else
+ begin
+ val(tok.pb.FBuf, numd, code);
+ TokRec^.current := TSuperObject.Create(numd);
+ end;
+ end else
+ begin
+ tok.err := teParseNumber;
+ goto out;
+ end;
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end
+ end;
+
+ tsArray:
+ begin
+ if (v = ']') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ TokRec^.state := tsArrayAdd;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end
+ end;
+
+ tsArrayAdd:
+ begin
+ TokRec^.current.AsArray.Add(obj);
+ TokRec^.saved_state := tsArraySep;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end;
+
+ tsArraySep:
+ begin
+ if (v = ']') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = ',') then
+ begin
+ TokRec^.saved_state := tsArray;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ tok.err := teParseArray;
+ goto out;
+ end
+ end;
+
+ tsObjectFieldStart:
+ begin
+ if (v = '}') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then
+ begin
+ tok.quote_char := v;
+ tok.pb.Reset;
+ TokRec^.state := tsObjectField;
+ end else
+ if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then
+ begin
+ TokRec^.state := tsObjectUnquotedField;
+ tok.pb.Reset;
+ goto redo_char;
+ end else
+ begin
+ tok.err := teParseObjectKeyName;
+ goto out;
+ end
+ end;
+
+ tsObjectField:
+ begin
+ if (v = tok.quote_char) then
+ begin
+ TokRec^.field_name := tok.pb.FBuf;
+ TokRec^.saved_state := tsObjectFieldEnd;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsObjectField;
+ TokRec^.state := tsStringEscape;
+ end else
+ begin
+ tok.pb.Append(@v, 1);
+ end
+ end;
+
+ tsObjectUnquotedField:
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then
+ begin
+ TokRec^.field_name := tok.pb.FBuf;
+ TokRec^.saved_state := tsObjectFieldEnd;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsObjectUnquotedField;
+ TokRec^.state := tsStringEscape;
+ end else
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsObjectFieldEnd:
+ begin
+ if (v = ':') then
+ begin
+ TokRec^.saved_state := tsObjectValue;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ tok.err := teParseObjectKeySep;
+ goto out;
+ end
+ end;
+
+ tsObjectValue:
+ begin
+ if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ TokRec^.state := tsObjectValueAdd;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+
+ tsObjectValueAdd:
+ begin
+ TokRec^.current.AsObject.PutO(TokRec^.field_name, obj);
+ TokRec^.field_name := '';
+ TokRec^.saved_state := tsObjectSep;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end;
+
+ tsObjectSep:
+ begin
+ if (v = '}') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = ',') then
+ begin
+ TokRec^.saved_state := tsObjectFieldStart;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ tok.err := teParseObjectValueSep;
+ goto out;
+ end
+ end;
+ end;
+ inc(str);
+ inc(tok.char_offset);
+ until v = #0;
+
+ if(TokRec^.state <> tsFinish) and
+ (TokRec^.saved_state <> tsFinish) then
+ tok.err := teParseEof;
+
+ out:
+ if(tok.err in [teSuccess]) then
+ begin
+{$IFDEF SUPER_METHOD}
+ if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
+ begin
+ sm := TokRec^.current.AsMethod;
+ sm(TokRec^.parent, put, Result);
+ end else
+{$ENDIF}
+ Result := TokRec^.current;
+ end else
+ Result := nil;
+end;
+
+procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value);
+end;
+
+procedure TSuperObject.PutB(const path: SOString; Value: Boolean);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+procedure TSuperObject.PutD(const path: SOString; Value: Double);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+procedure TSuperObject.PutC(const path: SOString; Value: Currency);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value));
+end;
+
+procedure TSuperObject.PutI(const path: SOString; Value: SuperInt);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+procedure TSuperObject.PutS(const path: SOString; const Value: SOString);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+begin
+ if GetInterface(IID, Obj) then
+ Result := 0
+ else
+ Result := E_NOINTERFACE;
+end;
+
+function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer;
+var
+ pb: TSuperWriterStream;
+begin
+ if escape then
+ pb := TSuperAnsiWriterStream.Create(stream) else
+ pb := TSuperUnicodeWriterStream.Create(stream);
+
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ pb.Reset;
+ pb.Free;
+ Result := 0;
+ Exit;
+ end;
+ Result := stream.Size;
+ pb.Free;
+end;
+
+function TSuperObject.CalcSize(indent, escape: boolean): integer;
+var
+ pb: TSuperWriterFake;
+begin
+ pb := TSuperWriterFake.Create;
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ pb.Free;
+ Result := 0;
+ Exit;
+ end;
+ Result := pb.FSize;
+ pb.Free;
+end;
+
+function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer;
+var
+ pb: TSuperWriterSock;
+begin
+ pb := TSuperWriterSock.Create(socket);
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ pb.Free;
+ Result := 0;
+ Exit;
+ end;
+ Result := pb.FSize;
+ pb.Free;
+end;
+
+constructor TSuperObject.Create(const s: SOString);
+begin
+ Create(stString);
+ FOString := s;
+end;
+
+procedure TSuperObject.Clear(all: boolean);
+begin
+ if FProcessing then exit;
+ FProcessing := true;
+ try
+ case FDataType of
+ stBoolean: FO.c_boolean := false;
+ stDouble: FO.c_double := 0.0;
+ stCurrency: FO.c_currency := 0.0;
+ stInt: FO.c_int := 0;
+ stObject: FO.c_object.Clear(all);
+ stArray: FO.c_array.Clear(all);
+ stString: FOString := '';
+{$IFDEF SUPER_METHOD}
+ stMethod: FO.c_method := nil;
+{$ENDIF}
+ end;
+ finally
+ FProcessing := false;
+ end;
+end;
+
+procedure TSuperObject.Pack(all: boolean = false);
+begin
+ if FProcessing then exit;
+ FProcessing := true;
+ try
+ case FDataType of
+ stObject: FO.c_object.Pack(all);
+ stArray: FO.c_array.Pack(all);
+ end;
+ finally
+ FProcessing := false;
+ end;
+end;
+
+function TSuperObject.GetN(const path: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, true, self);
+ if Result = nil then
+ Result := TSuperObject.Create(stNull);
+end;
+
+procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject);
+begin
+ if Value = nil then
+ ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else
+ ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value);
+end;
+
+function TSuperObject.Delete(const path: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, true, self, [foDelete]);
+end;
+
+function TSuperObject.Clone: ISuperObject;
+var
+ ite: TSuperObjectIter;
+ arr: TSuperArray;
+ j: integer;
+begin
+ case FDataType of
+ stBoolean: Result := TSuperObject.Create(FO.c_boolean);
+ stDouble: Result := TSuperObject.Create(FO.c_double);
+ stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency);
+ stInt: Result := TSuperObject.Create(FO.c_int);
+ stString: Result := TSuperObject.Create(FOString);
+{$IFDEF SUPER_METHOD}
+ stMethod: Result := TSuperObject.Create(FO.c_method);
+{$ENDIF}
+ stObject:
+ begin
+ Result := TSuperObject.Create(stObject);
+ if ObjectFindFirst(self, ite) then
+ with Result.AsObject do
+ repeat
+ PutO(ite.key, ite.val.Clone);
+ until not ObjectFindNext(ite);
+ ObjectFindClose(ite);
+ end;
+ stArray:
+ begin
+ Result := TSuperObject.Create(stArray);
+ arr := AsArray;
+ with Result.AsArray do
+ for j := 0 to arr.Length - 1 do
+ Add(arr.GetO(j).Clone);
+ end;
+ else
+ Result := nil;
+ end;
+end;
+
+procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean);
+var
+ prop1, prop2: ISuperObject;
+ ite: TSuperObjectIter;
+ arr: TSuperArray;
+ j: integer;
+begin
+ if ObjectIsType(obj, FDataType) then
+ case FDataType of
+ stBoolean: FO.c_boolean := obj.AsBoolean;
+ stDouble: FO.c_double := obj.AsDouble;
+ stCurrency: FO.c_currency := obj.AsCurrency;
+ stInt: FO.c_int := obj.AsInteger;
+ stString: FOString := obj.AsString;
+{$IFDEF SUPER_METHOD}
+ stMethod: FO.c_method := obj.AsMethod;
+{$ENDIF}
+ stObject:
+ begin
+ if ObjectFindFirst(obj, ite) then
+ with FO.c_object do
+ repeat
+ prop1 := FO.c_object.GetO(ite.key);
+ if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then
+ prop1.Merge(ite.val) else
+ if reference then
+ PutO(ite.key, ite.val) else
+ PutO(ite.key, ite.val.Clone);
+ until not ObjectFindNext(ite);
+ ObjectFindClose(ite);
+ end;
+ stArray:
+ begin
+ arr := obj.AsArray;
+ with FO.c_array do
+ for j := 0 to arr.Length - 1 do
+ begin
+ prop1 := GetO(j);
+ prop2 := arr.GetO(j);
+ if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then
+ prop1.Merge(prop2) else
+ if reference then
+ PutO(j, prop2) else
+ PutO(j, prop2.Clone);
+ end;
+ end;
+ end;
+end;
+
+procedure TSuperObject.Merge(const str: SOString);
+begin
+ Merge(TSuperObject.ParseString(PSOChar(str), False), true);
+end;
+
+class function TSuperObject.NewInstance: TObject;
+begin
+ Result := inherited NewInstance;
+ TSuperObject(Result).FRefCount := 1;
+end;
+
+function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType);
+end;
+
+function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString;
+var
+ p1, p2: PSOChar;
+begin
+ Result := '';
+ p2 := PSOChar(str);
+ p1 := p2;
+ while true do
+ if p2^ = BeginSep then
+ begin
+ if p2 > p1 then
+ Result := Result + Copy(p1, 0, p2-p1);
+ inc(p2);
+ p1 := p2;
+ while true do
+ if p2^ = EndSep then Break else
+ if p2^ = #0 then Exit else
+ inc(p2);
+ Result := Result + GetS(copy(p1, 0, p2-p1));
+ inc(p2);
+ p1 := p2;
+ end
+ else if p2^ = #0 then
+ begin
+ if p2 > p1 then
+ Result := Result + Copy(p1, 0, p2-p1);
+ Break;
+ end else
+ inc(p2);
+end;
+
+function TSuperObject.GetO(const path: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self);
+end;
+
+function TSuperObject.GetA(const path: SOString): TSuperArray;
+var
+ obj: ISuperObject;
+begin
+ obj := ParseString(PSOChar(path), False, True, Self);
+ if obj <> nil then
+ Result := obj.AsArray else
+ Result := nil;
+end;
+
+function TSuperObject.GetB(const path: SOString): Boolean;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsBoolean else
+ Result := false;
+end;
+
+function TSuperObject.GetD(const path: SOString): Double;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsDouble else
+ Result := 0.0;
+end;
+
+function TSuperObject.GetC(const path: SOString): Currency;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsCurrency else
+ Result := 0.0;
+end;
+
+function TSuperObject.GetI(const path: SOString): SuperInt;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsInteger else
+ Result := 0;
+end;
+
+function TSuperObject.GetDataPtr: Pointer;
+begin
+ Result := FDataPtr;
+end;
+
+function TSuperObject.GetDataType: TSuperType;
+begin
+ Result := FDataType
+end;
+
+function TSuperObject.GetS(const path: SOString): SOString;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsString else
+ Result := '';
+end;
+
+function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer;
+var
+ stream: TFileStream;
+begin
+ stream := TFileStream.Create(FileName, fmCreate);
+ try
+ Result := SaveTo(stream, indent, escape);
+ finally
+ stream.Free;
+ end;
+end;
+
+function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
+begin
+ Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender);
+end;
+
+function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
+type
+ TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool,
+ dtMap, dtSeq, dtScalar, dtAny);
+var
+ datatypes: ISuperObject;
+ names: ISuperObject;
+
+ function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject;
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ begin
+ o := p[prop];
+ if o <> nil then
+ result := o else
+ begin
+ o := p['inherit'];
+ if (o <> nil) and ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ Result := FindInheritedProperty(prop, e.Value) else
+ Result := nil;
+ end else
+ Result := nil;
+ end;
+ end;
+
+ function FindDataType(o: ISuperObject): TDataType;
+ var
+ e: TSuperAvlEntry;
+ obj: ISuperObject;
+ begin
+ obj := FindInheritedProperty('type', o);
+ if obj <> nil then
+ begin
+ e := datatypes.AsObject.Search(obj.AsString);
+ if e <> nil then
+ Result := TDataType(e.Value.AsInteger) else
+ Result := dtUnknown;
+ end else
+ Result := dtUnknown;
+ end;
+
+ procedure GetNames(o: ISuperObject);
+ var
+ obj: ISuperObject;
+ f: TSuperObjectIter;
+ begin
+ obj := o['name'];
+ if ObjectIsType(obj, stString) then
+ names[obj.AsString] := o;
+
+ case FindDataType(o) of
+ dtMap:
+ begin
+ obj := o['mapping'];
+ if ObjectIsType(obj, stObject) then
+ begin
+ if ObjectFindFirst(obj, f) then
+ repeat
+ if ObjectIsType(f.val, stObject) then
+ GetNames(f.val);
+ until not ObjectFindNext(f);
+ ObjectFindClose(f);
+ end;
+ end;
+ dtSeq:
+ begin
+ obj := o['sequence'];
+ if ObjectIsType(obj, stObject) then
+ GetNames(obj);
+ end;
+ end;
+ end;
+
+ function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject;
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ begin
+ o := p['mapping'];
+ if ObjectIsType(o, stObject) then
+ begin
+ o := o.AsObject.GetO(prop);
+ if o <> nil then
+ begin
+ Result := o;
+ Exit;
+ end;
+ end;
+
+ o := p['inherit'];
+ if ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ Result := FindInheritedField(prop, e.Value) else
+ Result := nil;
+ end else
+ Result := nil;
+ end;
+
+ function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean;
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ j: TSuperAvlIterator;
+ begin
+ Result := true;
+ o := p['mapping'];
+ if ObjectIsType(o, stObject) then
+ begin
+ j := TSuperAvlIterator.Create(o.AsObject);
+ try
+ j.First;
+ e := j.GetIter;
+ while e <> nil do
+ begin
+ if obj.AsObject.Search(e.Name) = nil then
+ begin
+ Result := False;
+ if assigned(callback) then
+ callback(sender, veFieldNotFound, name + '.' + e.Name);
+ end;
+ j.Next;
+ e := j.GetIter;
+ end;
+
+ finally
+ j.Free;
+ end;
+ end;
+
+ o := p['inherit'];
+ if ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ Result := InheritedFieldExist(obj, e.Value, name) and Result;
+ end;
+ end;
+
+ function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean;
+ var
+ o: ISuperObject;
+ begin
+ o := FindInheritedProperty(f, p);
+ case ObjectGetType(o) of
+ stBoolean: Result := o.AsBoolean;
+ stNull: Result := Default;
+ else
+ Result := default;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, f);
+ end;
+ end;
+
+ procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject);
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ i: TSuperAvlIterator;
+ begin
+ Result := true;
+ o := p['mapping'];
+ if ObjectIsType(o, stObject) then
+ begin
+ i := TSuperAvlIterator.Create(o.AsObject);
+ try
+ i.First;
+ e := i.GetIter;
+ while e <> nil do
+ begin
+ if list.AsObject.Search(e.Name) = nil then
+ list[e.Name] := e.Value;
+ i.Next;
+ e := i.GetIter;
+ end;
+
+ finally
+ i.Free;
+ end;
+ end;
+
+ o := p['inherit'];
+ if ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ GetInheritedFieldList(list, e.Value);
+ end;
+ end;
+
+ function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean;
+ var
+ enum: ISuperObject;
+ i: integer;
+ begin
+ Result := false;
+ enum := FindInheritedProperty('enum', p);
+ case ObjectGetType(enum) of
+ stArray:
+ for i := 0 to enum.AsArray.Length - 1 do
+ if (o.AsString = enum.AsArray[i].AsString) then
+ begin
+ Result := true;
+ exit;
+ end;
+ stNull: Result := true;
+ else
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ Exit;
+ end;
+
+ if (not Result) and assigned(callback) then
+ callback(sender, veValueNotInEnum, name);
+ end;
+
+ function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean;
+ var
+ length, o: ISuperObject;
+ begin
+ result := true;
+ length := FindInheritedProperty('length', p);
+ case ObjectGetType(length) of
+ stObject:
+ begin
+ o := length.AsObject.GetO('min');
+ if (o <> nil) and (o.AsInteger > len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ o := length.AsObject.GetO('max');
+ if (o <> nil) and (o.AsInteger < len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ o := length.AsObject.GetO('minex');
+ if (o <> nil) and (o.AsInteger >= len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ o := length.AsObject.GetO('maxex');
+ if (o <> nil) and (o.AsInteger <= len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ end;
+ stNull: ;
+ else
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ end;
+ end;
+
+ function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean;
+ var
+ length, o: ISuperObject;
+ begin
+ result := true;
+ length := FindInheritedProperty('range', p);
+ case ObjectGetType(length) of
+ stObject:
+ begin
+ o := length.AsObject.GetO('min');
+ if (o <> nil) and (o.Compare(obj) = cpGreat) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ o := length.AsObject.GetO('max');
+ if (o <> nil) and (o.Compare(obj) = cpLess) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ o := length.AsObject.GetO('minex');
+ if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ o := length.AsObject.GetO('maxex');
+ if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ end;
+ stNull: ;
+ else
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ end;
+ end;
+
+
+ function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean;
+ var
+ ite: TSuperAvlIterator;
+ ent: TSuperAvlEntry;
+ p2, o2, sequence: ISuperObject;
+ s: SOString;
+ i: integer;
+ uniquelist, fieldlist: ISuperObject;
+ begin
+ Result := true;
+ if (o = nil) then
+ begin
+ if getInheritedBool('required', p) then
+ begin
+ if assigned(callback) then
+ callback(sender, veFieldIsRequired, objpath);
+ result := false;
+ end;
+ end else
+ case FindDataType(p) of
+ dtStr:
+ case ObjectGetType(o) of
+ stString:
+ begin
+ Result := Result and CheckLength(Length(o.AsString), p, objpath);
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtBool:
+ case ObjectGetType(o) of
+ stBoolean:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtInt:
+ case ObjectGetType(o) of
+ stInt:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtFloat:
+ case ObjectGetType(o) of
+ stDouble, stCurrency:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtMap:
+ case ObjectGetType(o) of
+ stObject:
+ begin
+ // all objects have and match a rule ?
+ ite := TSuperAvlIterator.Create(o.AsObject);
+ try
+ ite.First;
+ ent := ite.GetIter;
+ while ent <> nil do
+ begin
+ p2 := FindInheritedField(ent.Name, p);
+ if ObjectIsType(p2, stObject) then
+ result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else
+ begin
+ if assigned(callback) then
+ callback(sender, veUnexpectedField, objpath + '.' + ent.Name);
+ result := false; // field have no rule
+ end;
+ ite.Next;
+ ent := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+
+ // all expected field exists ?
+ Result := InheritedFieldExist(o, p, objpath) and Result;
+ end;
+ stNull: {nop};
+ else
+ result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ end;
+ dtSeq:
+ case ObjectGetType(o) of
+ stArray:
+ begin
+ sequence := FindInheritedProperty('sequence', p);
+ if sequence <> nil then
+ case ObjectGetType(sequence) of
+ stObject:
+ begin
+ for i := 0 to o.AsArray.Length - 1 do
+ result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result;
+ if getInheritedBool('unique', sequence) then
+ begin
+ // type is unique ?
+ uniquelist := TSuperObject.Create(stObject);
+ try
+ for i := 0 to o.AsArray.Length - 1 do
+ begin
+ s := o.AsArray.GetO(i).AsString;
+ if (s <> '') then
+ begin
+ if uniquelist.AsObject.Search(s) = nil then
+ uniquelist[s] := nil else
+ begin
+ Result := False;
+ if Assigned(callback) then
+ callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']');
+ end;
+ end;
+ end;
+ finally
+ uniquelist := nil;
+ end;
+ end;
+
+ // field is unique ?
+ if (FindDataType(sequence) = dtMap) then
+ begin
+ fieldlist := TSuperObject.Create(stObject);
+ try
+ GetInheritedFieldList(fieldlist, sequence);
+ ite := TSuperAvlIterator.Create(fieldlist.AsObject);
+ try
+ ite.First;
+ ent := ite.GetIter;
+ while ent <> nil do
+ begin
+ if getInheritedBool('unique', ent.Value) then
+ begin
+ uniquelist := TSuperObject.Create(stObject);
+ try
+ for i := 0 to o.AsArray.Length - 1 do
+ begin
+ o2 := o.AsArray.GetO(i);
+ if o2 <> nil then
+ begin
+ s := o2.AsObject.GetO(ent.Name).AsString;
+ if (s <> '') then
+ if uniquelist.AsObject.Search(s) = nil then
+ uniquelist[s] := nil else
+ begin
+ Result := False;
+ if Assigned(callback) then
+ callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name);
+ end;
+ end;
+ end;
+ finally
+ uniquelist := nil;
+ end;
+ end;
+ ite.Next;
+ ent := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+ finally
+ fieldlist := nil;
+ end;
+ end;
+
+
+ end;
+ stNull: {nop};
+ else
+ result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ end;
+ Result := Result and CheckLength(o.AsArray.Length, p, objpath);
+
+ end;
+ else
+ result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ end;
+ dtNumber:
+ case ObjectGetType(o) of
+ stInt,
+ stDouble, stCurrency:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtText:
+ case ObjectGetType(o) of
+ stInt,
+ stDouble,
+ stCurrency,
+ stString:
+ begin
+ result := result and CheckLength(Length(o.AsString), p, objpath);
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtScalar:
+ case ObjectGetType(o) of
+ stBoolean,
+ stDouble,
+ stCurrency,
+ stInt,
+ stString:
+ begin
+ result := result and CheckLength(Length(o.AsString), p, objpath);
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtAny:;
+ else
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ result := false;
+ end;
+ Result := Result and CheckEnum(o, p, objpath)
+
+ end;
+var
+ j: integer;
+
+begin
+ Result := False;
+ datatypes := TSuperObject.Create(stObject);
+ names := TSuperObject.Create;
+ try
+ datatypes.I['str'] := ord(dtStr);
+ datatypes.I['int'] := ord(dtInt);
+ datatypes.I['float'] := ord(dtFloat);
+ datatypes.I['number'] := ord(dtNumber);
+ datatypes.I['text'] := ord(dtText);
+ datatypes.I['bool'] := ord(dtBool);
+ datatypes.I['map'] := ord(dtMap);
+ datatypes.I['seq'] := ord(dtSeq);
+ datatypes.I['scalar'] := ord(dtScalar);
+ datatypes.I['any'] := ord(dtAny);
+
+ if ObjectIsType(defs, stArray) then
+ for j := 0 to defs.AsArray.Length - 1 do
+ if ObjectIsType(defs.AsArray[j], stObject) then
+ GetNames(defs.AsArray[j]) else
+ begin
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ Exit;
+ end;
+
+
+ if ObjectIsType(rules, stObject) then
+ GetNames(rules) else
+ begin
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ Exit;
+ end;
+
+ Result := process(self, rules);
+
+ finally
+ datatypes := nil;
+ names := nil;
+ end;
+end;
+
+function TSuperObject._AddRef: Integer; stdcall;
+begin
+ Result := InterlockedIncrement(FRefCount);
+end;
+
+function TSuperObject._Release: Integer; stdcall;
+begin
+ Result := InterlockedDecrement(FRefCount);
+ if Result = 0 then
+ Destroy;
+end;
+
+function TSuperObject.Compare(const str: SOString): TSuperCompareResult;
+begin
+ Result := Compare(TSuperObject.ParseString(PSOChar(str), False));
+end;
+
+function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult;
+ function GetIntCompResult(const i: int64): TSuperCompareResult;
+ begin
+ if i < 0 then result := cpLess else
+ if i = 0 then result := cpEqu else
+ Result := cpGreat;
+ end;
+
+ function GetDblCompResult(const d: double): TSuperCompareResult;
+ begin
+ if d < 0 then result := cpLess else
+ if d = 0 then result := cpEqu else
+ Result := cpGreat;
+ end;
+
+begin
+ case DataType of
+ stBoolean:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency);
+ stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stDouble:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency);
+ stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stCurrency:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency);
+ stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stInt:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency);
+ stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stString:
+ case ObjectGetType(obj) of
+ stBoolean,
+ stDouble,
+ stCurrency,
+ stInt,
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ else
+ Result := cpError;
+ end;
+end;
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.AsMethod: TSuperMethod;
+begin
+ if FDataType = stMethod then
+ Result := FO.c_method else
+ Result := nil;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+constructor TSuperObject.Create(m: TSuperMethod);
+begin
+ Create(stMethod);
+ FO.c_method := m;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.GetM(const path: SOString): TSuperMethod;
+var
+ v: ISuperObject;
+begin
+ v := ParseString(PSOChar(path), False, True, Self);
+ if (v <> nil) and (ObjectGetType(v) = stMethod) then
+ Result := v.AsMethod else
+ Result := nil;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod);
+begin
+ ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param);
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.call(const path, param: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False));
+end;
+{$ENDIF}
+
+function TSuperObject.GetProcessing: boolean;
+begin
+ Result := FProcessing;
+end;
+
+procedure TSuperObject.SetDataPtr(const Value: Pointer);
+begin
+ FDataPtr := Value;
+end;
+
+procedure TSuperObject.SetProcessing(value: boolean);
+begin
+ FProcessing := value;
+end;
+
+{ TSuperArray }
+
+function TSuperArray.Add(const Data: ISuperObject): Integer;
+begin
+ Result := FLength;
+ PutO(Result, data);
+end;
+
+function TSuperArray.Delete(index: Integer): ISuperObject;
+begin
+ if (Index >= 0) and (Index < FLength) then
+ begin
+ Result := FArray^[index];
+ FArray^[index] := nil;
+ Dec(FLength);
+ if Index < FLength then
+ begin
+ Move(FArray^[index + 1], FArray^[index],
+ (FLength - index) * SizeOf(Pointer));
+ Pointer(FArray^[FLength]) := nil;
+ end;
+ end;
+end;
+
+procedure TSuperArray.Insert(index: Integer; const value: ISuperObject);
+begin
+ if (Index >= 0) then
+ if (index < FLength) then
+ begin
+ if FLength = FSize then
+ Expand(index);
+ if Index < FLength then
+ Move(FArray^[index], FArray^[index + 1],
+ (FLength - index) * SizeOf(Pointer));
+ Pointer(FArray^[index]) := nil;
+ FArray^[index] := value;
+ Inc(FLength);
+ end else
+ PutO(index, value);
+end;
+
+procedure TSuperArray.Clear(all: boolean);
+var
+ j: Integer;
+begin
+ for j := 0 to FLength - 1 do
+ if FArray^[j] <> nil then
+ begin
+ if all then
+ FArray^[j].Clear(all);
+ FArray^[j] := nil;
+ end;
+ FLength := 0;
+end;
+
+procedure TSuperArray.Pack(all: boolean);
+var
+ PackedCount, StartIndex, EndIndex, j: Integer;
+begin
+ if FLength > 0 then
+ begin
+ PackedCount := 0;
+ StartIndex := 0;
+ repeat
+ while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do
+ Inc(StartIndex);
+ if StartIndex < FLength then
+ begin
+ EndIndex := StartIndex;
+ while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do
+ Inc(EndIndex);
+
+ Dec(EndIndex);
+
+ if StartIndex > PackedCount then
+ Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer));
+
+ Inc(PackedCount, EndIndex - StartIndex + 1);
+ StartIndex := EndIndex + 1;
+ end;
+ until StartIndex >= FLength;
+ FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0);
+ FLength := PackedCount;
+ if all then
+ for j := 0 to FLength - 1 do
+ FArray^[j].Pack(all);
+ end;
+end;
+
+constructor TSuperArray.Create;
+begin
+ inherited Create;
+ FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE;
+ FLength := 0;
+ GetMem(FArray, sizeof(Pointer) * FSize);
+ FillChar(FArray^, sizeof(Pointer) * FSize, 0);
+end;
+
+destructor TSuperArray.Destroy;
+begin
+ Clear;
+ FreeMem(FArray);
+ inherited;
+end;
+
+procedure TSuperArray.Expand(max: Integer);
+var
+ new_size: Integer;
+begin
+ if (max < FSize) then
+ Exit;
+ if max < (FSize shl 1) then
+ new_size := (FSize shl 1) else
+ new_size := max + 1;
+ ReallocMem(FArray, new_size * sizeof(Pointer));
+ FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0);
+ FSize := new_size;
+end;
+
+function TSuperArray.GetO(const index: Integer): ISuperObject;
+begin
+ if(index >= FLength) then
+ Result := nil else
+ Result := FArray^[index];
+end;
+
+function TSuperArray.GetB(const index: integer): Boolean;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsBoolean else
+ Result := false;
+end;
+
+function TSuperArray.GetD(const index: integer): Double;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsDouble else
+ Result := 0.0;
+end;
+
+function TSuperArray.GetI(const index: integer): SuperInt;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsInteger else
+ Result := 0;
+end;
+
+function TSuperArray.GetS(const index: integer): SOString;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsString else
+ Result := '';
+end;
+
+procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject);
+begin
+ Expand(index);
+ FArray^[index] := value;
+ if(FLength <= index) then FLength := index + 1;
+end;
+
+function TSuperArray.GetN(const index: integer): ISuperObject;
+begin
+ Result := GetO(index);
+ if Result = nil then
+ Result := TSuperObject.Create(stNull);
+end;
+
+procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject);
+begin
+ if Value <> nil then
+ PutO(index, Value) else
+ PutO(index, TSuperObject.Create(stNull));
+end;
+
+procedure TSuperArray.PutB(const index: integer; Value: Boolean);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+procedure TSuperArray.PutD(const index: integer; Value: Double);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+function TSuperArray.GetC(const index: integer): Currency;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsCurrency else
+ Result := 0.0;
+end;
+
+procedure TSuperArray.PutC(const index: integer; Value: Currency);
+begin
+ PutO(index, TSuperObject.CreateCurrency(Value));
+end;
+
+procedure TSuperArray.PutI(const index: integer; Value: SuperInt);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+procedure TSuperArray.PutS(const index: integer; const Value: SOString);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+{$IFDEF SUPER_METHOD}
+function TSuperArray.GetM(const index: integer): TSuperMethod;
+var
+ v: ISuperObject;
+begin
+ v := GetO(index);
+ if (ObjectGetType(v) = stMethod) then
+ Result := v.AsMethod else
+ Result := nil;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+{$ENDIF}
+
+{ TSuperWriterString }
+
+function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer;
+ function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end;
+begin
+ Result := size;
+ if Size > 0 then
+ begin
+ if (FSize - FBPos <= size) then
+ begin
+ FSize := max(FSize * 2, FBPos + size + 8);
+ ReallocMem(FBuf, FSize * SizeOf(SOChar));
+ end;
+ // fast move
+ case size of
+ 1: FBuf[FBPos] := buf^;
+ 2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^;
+ 4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^;
+ else
+ move(buf^, FBuf[FBPos], size * SizeOf(SOChar));
+ end;
+ inc(FBPos, size);
+ FBuf[FBPos] := #0;
+ end;
+end;
+
+function TSuperWriterString.Append(buf: PSOChar): Integer;
+begin
+ Result := Append(buf, strlen(buf));
+end;
+
+constructor TSuperWriterString.Create;
+begin
+ inherited;
+ FSize := 32;
+ FBPos := 0;
+ GetMem(FBuf, FSize * SizeOf(SOChar));
+end;
+
+destructor TSuperWriterString.Destroy;
+begin
+ inherited;
+ if FBuf <> nil then
+ FreeMem(FBuf)
+end;
+
+function TSuperWriterString.GetString: SOString;
+begin
+ SetString(Result, FBuf, FBPos);
+end;
+
+procedure TSuperWriterString.Reset;
+begin
+ FBuf[0] := #0;
+ FBPos := 0;
+end;
+
+procedure TSuperWriterString.TrimRight;
+begin
+ while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do
+ begin
+ dec(FBPos);
+ FBuf[FBPos] := #0;
+ end;
+end;
+
+{ TSuperWriterStream }
+
+function TSuperWriterStream.Append(buf: PSOChar): Integer;
+begin
+ Result := Append(buf, StrLen(buf));
+end;
+
+constructor TSuperWriterStream.Create(AStream: TStream);
+begin
+ inherited Create;
+ FStream := AStream;
+end;
+
+procedure TSuperWriterStream.Reset;
+begin
+ FStream.Size := 0;
+end;
+
+{ TSuperWriterStream }
+
+function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
+var
+ Buffer: array[0..1023] of AnsiChar;
+ pBuffer: PAnsiChar;
+ i: Integer;
+begin
+ if Size = 1 then
+ Result := FStream.Write(buf^, Size) else
+ begin
+ if Size > SizeOf(Buffer) then
+ GetMem(pBuffer, Size) else
+ pBuffer := @Buffer;
+ try
+ for i := 0 to Size - 1 do
+ pBuffer[i] := AnsiChar(buf[i]);
+ Result := FStream.Write(pBuffer^, Size);
+ finally
+ if pBuffer <> @Buffer then
+ FreeMem(pBuffer);
+ end;
+ end;
+end;
+
+{ TSuperUnicodeWriterStream }
+
+function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
+begin
+ Result := FStream.Write(buf^, Size * 2);
+end;
+
+{ TSuperWriterFake }
+
+function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer;
+begin
+ inc(FSize, Size);
+ Result := FSize;
+end;
+
+function TSuperWriterFake.Append(buf: PSOChar): Integer;
+begin
+ inc(FSize, Strlen(buf));
+ Result := FSize;
+end;
+
+constructor TSuperWriterFake.Create;
+begin
+ inherited Create;
+ FSize := 0;
+end;
+
+procedure TSuperWriterFake.Reset;
+begin
+ FSize := 0;
+end;
+
+{ TSuperWriterSock }
+
+function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer;
+var
+ Buffer: array[0..1023] of AnsiChar;
+ pBuffer: PAnsiChar;
+ i: Integer;
+begin
+ if Size = 1 then
+{$IFDEF FPC}
+ Result := fpsend(FSocket, buf, size, 0) else
+{$ELSE}
+ Result := send(FSocket, buf^, size, 0) else
+{$ENDIF}
+ begin
+ if Size > SizeOf(Buffer) then
+ GetMem(pBuffer, Size) else
+ pBuffer := @Buffer;
+ try
+ for i := 0 to Size - 1 do
+ pBuffer[i] := AnsiChar(buf[i]);
+{$IFDEF FPC}
+ Result := fpsend(FSocket, pBuffer, size, 0);
+{$ELSE}
+ Result := send(FSocket, pBuffer^, size, 0);
+{$ENDIF}
+ finally
+ if pBuffer <> @Buffer then
+ FreeMem(pBuffer);
+ end;
+ end;
+ inc(FSize, Result);
+end;
+
+function TSuperWriterSock.Append(buf: PSOChar): Integer;
+begin
+ Result := Append(buf, StrLen(buf));
+end;
+
+constructor TSuperWriterSock.Create(ASocket: Integer);
+begin
+ inherited Create;
+ FSocket := ASocket;
+ FSize := 0;
+end;
+
+procedure TSuperWriterSock.Reset;
+begin
+ FSize := 0;
+end;
+
+{ TSuperTokenizer }
+
+constructor TSuperTokenizer.Create;
+begin
+ pb := TSuperWriterString.Create;
+ line := 1;
+ col := 0;
+ Reset;
+end;
+
+destructor TSuperTokenizer.Destroy;
+begin
+ Reset;
+ pb.Free;
+ inherited;
+end;
+
+procedure TSuperTokenizer.Reset;
+var
+ i: integer;
+begin
+ for i := depth downto 0 do
+ ResetLevel(i);
+ depth := 0;
+ err := teSuccess;
+end;
+
+procedure TSuperTokenizer.ResetLevel(adepth: integer);
+begin
+ stack[adepth].state := tsEatws;
+ stack[adepth].saved_state := tsStart;
+ stack[adepth].current := nil;
+ stack[adepth].field_name := '';
+ stack[adepth].obj := nil;
+ stack[adepth].parent := nil;
+ stack[adepth].gparent := nil;
+end;
+
+{ TSuperAvlTree }
+
+constructor TSuperAvlTree.Create;
+begin
+ FRoot := nil;
+ FCount := 0;
+end;
+
+destructor TSuperAvlTree.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+
+function TSuperAvlTree.IsEmpty: boolean;
+begin
+ result := FRoot = nil;
+end;
+
+function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry;
+var
+ deep, old: TSuperAvlEntry;
+ bf: integer;
+begin
+ if (bal.FBf > 0) then
+ begin
+ deep := bal.FGt;
+ if (deep.FBf < 0) then
+ begin
+ old := bal;
+ bal := deep.FLt;
+ old.FGt := bal.FLt;
+ deep.FLt := bal.FGt;
+ bal.FLt := old;
+ bal.FGt := deep;
+ bf := bal.FBf;
+ if (bf <> 0) then
+ begin
+ if (bf > 0) then
+ begin
+ old.FBf := -1;
+ deep.FBf := 0;
+ end else
+ begin
+ deep.FBf := 1;
+ old.FBf := 0;
+ end;
+ bal.FBf := 0;
+ end else
+ begin
+ old.FBf := 0;
+ deep.FBf := 0;
+ end;
+ end else
+ begin
+ bal.FGt := deep.FLt;
+ deep.FLt := bal;
+ if (deep.FBf = 0) then
+ begin
+ deep.FBf := -1;
+ bal.FBf := 1;
+ end else
+ begin
+ deep.FBf := 0;
+ bal.FBf := 0;
+ end;
+ bal := deep;
+ end;
+ end else
+ begin
+ (* "Less than" subtree is deeper. *)
+
+ deep := bal.FLt;
+ if (deep.FBf > 0) then
+ begin
+ old := bal;
+ bal := deep.FGt;
+ old.FLt := bal.FGt;
+ deep.FGt := bal.FLt;
+ bal.FGt := old;
+ bal.FLt := deep;
+
+ bf := bal.FBf;
+ if (bf <> 0) then
+ begin
+ if (bf < 0) then
+ begin
+ old.FBf := 1;
+ deep.FBf := 0;
+ end else
+ begin
+ deep.FBf := -1;
+ old.FBf := 0;
+ end;
+ bal.FBf := 0;
+ end else
+ begin
+ old.FBf := 0;
+ deep.FBf := 0;
+ end;
+ end else
+ begin
+ bal.FLt := deep.FGt;
+ deep.FGt := bal;
+ if (deep.FBf = 0) then
+ begin
+ deep.FBf := 1;
+ bal.FBf := -1;
+ end else
+ begin
+ deep.FBf := 0;
+ bal.FBf := 0;
+ end;
+ bal := deep;
+ end;
+ end;
+ Result := bal;
+end;
+
+function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry;
+var
+ unbal, parentunbal, hh, parent: TSuperAvlEntry;
+ depth, unbaldepth: longint;
+ cmp: integer;
+ unbalbf: integer;
+ branch: TSuperAvlBitArray;
+ p: Pointer;
+begin
+ inc(FCount);
+ h.FLt := nil;
+ h.FGt := nil;
+ h.FBf := 0;
+ branch := [];
+
+ if (FRoot = nil) then
+ FRoot := h
+ else
+ begin
+ unbal := nil;
+ parentunbal := nil;
+ depth := 0;
+ unbaldepth := 0;
+ hh := FRoot;
+ parent := nil;
+ repeat
+ if (hh.FBf <> 0) then
+ begin
+ unbal := hh;
+ parentunbal := parent;
+ unbaldepth := depth;
+ end;
+ if hh.FHash <> h.FHash then
+ begin
+ if hh.FHash < h.FHash then cmp := -1 else
+ if hh.FHash > h.FHash then cmp := 1 else
+ cmp := 0;
+ end else
+ cmp := CompareNodeNode(h, hh);
+ if (cmp = 0) then
+ begin
+ Result := hh;
+ //exchange data
+ p := hh.Ptr;
+ hh.FPtr := h.Ptr;
+ h.FPtr := p;
+ doDeleteEntry(h, false);
+ dec(FCount);
+ exit;
+ end;
+ parent := hh;
+ if (cmp > 0) then
+ begin
+ hh := hh.FGt;
+ include(branch, depth);
+ end else
+ begin
+ hh := hh.FLt;
+ exclude(branch, depth);
+ end;
+ inc(depth);
+ until (hh = nil);
+
+ if (cmp < 0) then
+ parent.FLt := h else
+ parent.FGt := h;
+
+ depth := unbaldepth;
+
+ if (unbal = nil) then
+ hh := FRoot
+ else
+ begin
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ inc(depth);
+ unbalbf := unbal.FBf;
+ if (cmp < 0) then
+ dec(unbalbf) else
+ inc(unbalbf);
+ if cmp < 0 then
+ hh := unbal.FLt else
+ hh := unbal.FGt;
+ if ((unbalbf <> -2) and (unbalbf <> 2)) then
+ begin
+ unbal.FBf := unbalbf;
+ unbal := nil;
+ end;
+ end;
+
+ if (hh <> nil) then
+ while (h <> hh) do
+ begin
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ inc(depth);
+ if (cmp < 0) then
+ begin
+ hh.FBf := -1;
+ hh := hh.FLt;
+ end else (* cmp > 0 *)
+ begin
+ hh.FBf := 1;
+ hh := hh.FGt;
+ end;
+ end;
+
+ if (unbal <> nil) then
+ begin
+ unbal := balance(unbal);
+ if (parentunbal = nil) then
+ FRoot := unbal
+ else
+ begin
+ depth := unbaldepth - 1;
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ if (cmp < 0) then
+ parentunbal.FLt := unbal else
+ parentunbal.FGt := unbal;
+ end;
+ end;
+ end;
+ result := h;
+end;
+
+function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry;
+var
+ cmp, target_cmp: integer;
+ match_h, h: TSuperAvlEntry;
+ ha: Cardinal;
+begin
+ ha := TSuperAvlEntry.Hash(k);
+
+ match_h := nil;
+ h := FRoot;
+
+ if (stLess in st) then
+ target_cmp := 1 else
+ if (stGreater in st) then
+ target_cmp := -1 else
+ target_cmp := 0;
+
+ while (h <> nil) do
+ begin
+ if h.FHash < ha then cmp := -1 else
+ if h.FHash > ha then cmp := 1 else
+ cmp := 0;
+
+ if cmp = 0 then
+ cmp := CompareKeyNode(PSOChar(k), h);
+ if (cmp = 0) then
+ begin
+ if (stEqual in st) then
+ begin
+ match_h := h;
+ break;
+ end;
+ cmp := -target_cmp;
+ end
+ else
+ if (target_cmp <> 0) then
+ if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
+ match_h := h;
+ if cmp < 0 then
+ h := h.FLt else
+ h := h.FGt;
+ end;
+ result := match_h;
+end;
+
+function TSuperAvlTree.Delete(const k: SOString): ISuperObject;
+var
+ depth, rm_depth: longint;
+ branch: TSuperAvlBitArray;
+ h, parent, child, path, rm, parent_rm: TSuperAvlEntry;
+ cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer;
+ ha: Cardinal;
+begin
+ ha := TSuperAvlEntry.Hash(k);
+ cmp_shortened_sub_with_path := 0;
+ branch := [];
+
+ depth := 0;
+ h := FRoot;
+ parent := nil;
+ while true do
+ begin
+ if (h = nil) then
+ exit;
+ if h.FHash < ha then cmp := -1 else
+ if h.FHash > ha then cmp := 1 else
+ cmp := 0;
+
+ if cmp = 0 then
+ cmp := CompareKeyNode(k, h);
+ if (cmp = 0) then
+ break;
+ parent := h;
+ if (cmp > 0) then
+ begin
+ h := h.FGt;
+ include(branch, depth)
+ end else
+ begin
+ h := h.FLt;
+ exclude(branch, depth)
+ end;
+ inc(depth);
+ cmp_shortened_sub_with_path := cmp;
+ end;
+ rm := h;
+ parent_rm := parent;
+ rm_depth := depth;
+
+ if (h.FBf < 0) then
+ begin
+ child := h.FLt;
+ exclude(branch, depth);
+ cmp := -1;
+ end else
+ begin
+ child := h.FGt;
+ include(branch, depth);
+ cmp := 1;
+ end;
+ inc(depth);
+
+ if (child <> nil) then
+ begin
+ cmp := -cmp;
+ repeat
+ parent := h;
+ h := child;
+ if (cmp < 0) then
+ begin
+ child := h.FLt;
+ exclude(branch, depth);
+ end else
+ begin
+ child := h.FGt;
+ include(branch, depth);
+ end;
+ inc(depth);
+ until (child = nil);
+
+ if (parent = rm) then
+ cmp_shortened_sub_with_path := -cmp else
+ cmp_shortened_sub_with_path := cmp;
+
+ if cmp > 0 then
+ child := h.FLt else
+ child := h.FGt;
+ end;
+
+ if (parent = nil) then
+ FRoot := child else
+ if (cmp_shortened_sub_with_path < 0) then
+ parent.FLt := child else
+ parent.FGt := child;
+
+ if parent = rm then
+ path := h else
+ path := parent;
+
+ if (h <> rm) then
+ begin
+ h.FLt := rm.FLt;
+ h.FGt := rm.FGt;
+ h.FBf := rm.FBf;
+ if (parent_rm = nil) then
+ FRoot := h
+ else
+ begin
+ depth := rm_depth - 1;
+ if (depth in branch) then
+ parent_rm.FGt := h else
+ parent_rm.FLt := h;
+ end;
+ end;
+
+ if (path <> nil) then
+ begin
+ h := FRoot;
+ parent := nil;
+ depth := 0;
+ while (h <> path) do
+ begin
+ if (depth in branch) then
+ begin
+ child := h.FGt;
+ h.FGt := parent;
+ end else
+ begin
+ child := h.FLt;
+ h.FLt := parent;
+ end;
+ inc(depth);
+ parent := h;
+ h := child;
+ end;
+
+ reduced_depth := 1;
+ cmp := cmp_shortened_sub_with_path;
+ while true do
+ begin
+ if (reduced_depth <> 0) then
+ begin
+ bf := h.FBf;
+ if (cmp < 0) then
+ inc(bf) else
+ dec(bf);
+ if ((bf = -2) or (bf = 2)) then
+ begin
+ h := balance(h);
+ bf := h.FBf;
+ end else
+ h.FBf := bf;
+ reduced_depth := integer(bf = 0);
+ end;
+ if (parent = nil) then
+ break;
+ child := h;
+ h := parent;
+ dec(depth);
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ if (cmp < 0) then
+ begin
+ parent := h.FLt;
+ h.FLt := child;
+ end else
+ begin
+ parent := h.FGt;
+ h.FGt := child;
+ end;
+ end;
+ FRoot := h;
+ end;
+ if rm <> nil then
+ begin
+ Result := rm.GetValue;
+ doDeleteEntry(rm, false);
+ dec(FCount);
+ end;
+end;
+
+procedure TSuperAvlTree.Pack(all: boolean);
+var
+ node1, node2: TSuperAvlEntry;
+ list: TList;
+ i: Integer;
+begin
+ node1 := FRoot;
+ list := TList.Create;
+ while node1 <> nil do
+ begin
+ if (node1.FLt = nil) then
+ begin
+ node2 := node1.FGt;
+ if (node1.FPtr = nil) then
+ list.Add(node1) else
+ if all then
+ node1.Value.Pack(all);
+ end
+ else
+ begin
+ node2 := node1.FLt;
+ node1.FLt := node2.FGt;
+ node2.FGt := node1;
+ end;
+ node1 := node2;
+ end;
+ for i := 0 to list.Count - 1 do
+ Delete(TSuperAvlEntry(list[i]).FName);
+ list.Free;
+end;
+
+procedure TSuperAvlTree.Clear(all: boolean);
+var
+ node1, node2: TSuperAvlEntry;
+begin
+ node1 := FRoot;
+ while node1 <> nil do
+ begin
+ if (node1.FLt = nil) then
+ begin
+ node2 := node1.FGt;
+ doDeleteEntry(node1, all);
+ end
+ else
+ begin
+ node2 := node1.FLt;
+ node1.FLt := node2.FGt;
+ node2.FGt := node1;
+ end;
+ node1 := node2;
+ end;
+ FRoot := nil;
+ FCount := 0;
+end;
+
+function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer;
+begin
+ Result := StrComp(PSOChar(k), PSOChar(h.FName));
+end;
+
+function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer;
+begin
+ Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName));
+end;
+
+{ TSuperAvlIterator }
+
+(* Initialize depth to invalid value, to indicate iterator is
+** invalid. (Depth is zero-base.) It's not necessary to initialize
+** iterators prior to passing them to the "start" function.
+*)
+
+constructor TSuperAvlIterator.Create(tree: TSuperAvlTree);
+begin
+ FDepth := not 0;
+ FTree := tree;
+end;
+
+procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes);
+var
+ h: TSuperAvlEntry;
+ d: longint;
+ cmp, target_cmp: integer;
+ ha: Cardinal;
+begin
+ ha := TSuperAvlEntry.Hash(k);
+ h := FTree.FRoot;
+ d := 0;
+ FDepth := not 0;
+ if (h = nil) then
+ exit;
+
+ if (stLess in st) then
+ target_cmp := 1 else
+ if (stGreater in st) then
+ target_cmp := -1 else
+ target_cmp := 0;
+
+ while true do
+ begin
+ if h.FHash < ha then cmp := -1 else
+ if h.FHash > ha then cmp := 1 else
+ cmp := 0;
+
+ if cmp = 0 then
+ cmp := FTree.CompareKeyNode(k, h);
+ if (cmp = 0) then
+ begin
+ if (stEqual in st) then
+ begin
+ FDepth := d;
+ break;
+ end;
+ cmp := -target_cmp;
+ end
+ else
+ if (target_cmp <> 0) then
+ if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
+ FDepth := d;
+ if cmp < 0 then
+ h := h.FLt else
+ h := h.FGt;
+ if (h = nil) then
+ break;
+ if (cmp > 0) then
+ include(FBranch, d) else
+ exclude(FBranch, d);
+ FPath[d] := h;
+ inc(d);
+ end;
+end;
+
+procedure TSuperAvlIterator.First;
+var
+ h: TSuperAvlEntry;
+begin
+ h := FTree.FRoot;
+ FDepth := not 0;
+ FBranch := [];
+ while (h <> nil) do
+ begin
+ if (FDepth <> not 0) then
+ FPath[FDepth] := h;
+ inc(FDepth);
+ h := h.FLt;
+ end;
+end;
+
+procedure TSuperAvlIterator.Last;
+var
+ h: TSuperAvlEntry;
+begin
+ h := FTree.FRoot;
+ FDepth := not 0;
+ FBranch := [0..SUPER_AVL_MAX_DEPTH - 1];
+ while (h <> nil) do
+ begin
+ if (FDepth <> not 0) then
+ FPath[FDepth] := h;
+ inc(FDepth);
+ h := h.FGt;
+ end;
+end;
+
+function TSuperAvlIterator.MoveNext: boolean;
+begin
+ if FDepth = not 0 then
+ First else
+ Next;
+ Result := GetIter <> nil;
+end;
+
+function TSuperAvlIterator.GetIter: TSuperAvlEntry;
+begin
+ if (FDepth = not 0) then
+ begin
+ result := nil;
+ exit;
+ end;
+ if FDepth = 0 then
+ Result := FTree.FRoot else
+ Result := FPath[FDepth - 1];
+end;
+
+procedure TSuperAvlIterator.Next;
+var
+ h: TSuperAvlEntry;
+begin
+ if (FDepth <> not 0) then
+ begin
+ if FDepth = 0 then
+ h := FTree.FRoot.FGt else
+ h := FPath[FDepth - 1].FGt;
+
+ if (h = nil) then
+ repeat
+ if (FDepth = 0) then
+ begin
+ FDepth := not 0;
+ break;
+ end;
+ dec(FDepth);
+ until (not (FDepth in FBranch))
+ else
+ begin
+ include(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ while true do
+ begin
+ h := h.FLt;
+ if (h = nil) then
+ break;
+ exclude(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ end;
+ end;
+ end;
+end;
+
+procedure TSuperAvlIterator.Prior;
+var
+ h: TSuperAvlEntry;
+begin
+ if (FDepth <> not 0) then
+ begin
+ if FDepth = 0 then
+ h := FTree.FRoot.FLt else
+ h := FPath[FDepth - 1].FLt;
+ if (h = nil) then
+ repeat
+ if (FDepth = 0) then
+ begin
+ FDepth := not 0;
+ break;
+ end;
+ dec(FDepth);
+ until (FDepth in FBranch)
+ else
+ begin
+ exclude(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ while true do
+ begin
+ h := h.FGt;
+ if (h = nil) then
+ break;
+ include(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ end;
+ end;
+ end;
+end;
+
+procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
+begin
+ Entry.Free;
+end;
+
+function TSuperAvlTree.GetEnumerator: TSuperAvlIterator;
+begin
+ Result := TSuperAvlIterator.Create(Self);
+end;
+
+{ TSuperAvlEntry }
+
+constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer);
+begin
+ FName := AName;
+ FPtr := Obj;
+ FHash := Hash(FName);
+end;
+
+function TSuperAvlEntry.GetValue: ISuperObject;
+begin
+ Result := ISuperObject(FPtr)
+end;
+
+class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;
+var
+ h: cardinal;
+ i: Integer;
+begin
+ h := 0;
+{$Q-}
+ for i := 1 to Length(k) do
+ h := h*129 + ord(k[i]) + $9e370001;
+{$Q+}
+ Result := h;
+end;
+
+procedure TSuperAvlEntry.SetValue(const val: ISuperObject);
+begin
+ ISuperObject(FPtr) := val;
+end;
+
+{ TSuperTableString }
+
+function TSuperTableString.GetValues: ISuperObject;
+var
+ ite: TSuperAvlIterator;
+ obj: TSuperAvlEntry;
+begin
+ Result := TSuperObject.Create(stArray);
+ ite := TSuperAvlIterator.Create(Self);
+ try
+ ite.First;
+ obj := ite.GetIter;
+ while obj <> nil do
+ begin
+ Result.AsArray.Add(obj.Value);
+ ite.Next;
+ obj := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+end;
+
+function TSuperTableString.GetNames: ISuperObject;
+var
+ ite: TSuperAvlIterator;
+ obj: TSuperAvlEntry;
+begin
+ Result := TSuperObject.Create(stArray);
+ ite := TSuperAvlIterator.Create(Self);
+ try
+ ite.First;
+ obj := ite.GetIter;
+ while obj <> nil do
+ begin
+ Result.AsArray.Add(TSuperObject.Create(obj.FName));
+ ite.Next;
+ obj := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+end;
+
+procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
+begin
+ if Entry.Ptr <> nil then
+ begin
+ if all then Entry.Value.Clear(true);
+ Entry.Value := nil;
+ end;
+ inherited;
+end;
+
+function TSuperTableString.GetO(const k: SOString): ISuperObject;
+var
+ e: TSuperAvlEntry;
+begin
+ e := Search(k);
+ if e <> nil then
+ Result := e.Value else
+ Result := nil
+end;
+
+procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject);
+var
+ entry: TSuperAvlEntry;
+begin
+ entry := Insert(TSuperAvlEntry.Create(k, Pointer(value)));
+ if entry.FPtr <> nil then
+ ISuperObject(entry.FPtr)._AddRef;
+end;
+
+procedure TSuperTableString.PutS(const k: SOString; const value: SOString);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+function TSuperTableString.GetS(const k: SOString): SOString;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsString else
+ Result := '';
+end;
+
+procedure TSuperTableString.PutI(const k: SOString; value: SuperInt);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+function TSuperTableString.GetI(const k: SOString): SuperInt;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsInteger else
+ Result := 0;
+end;
+
+procedure TSuperTableString.PutD(const k: SOString; value: Double);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+procedure TSuperTableString.PutC(const k: SOString; value: Currency);
+begin
+ PutO(k, TSuperObject.CreateCurrency(Value));
+end;
+
+function TSuperTableString.GetC(const k: SOString): Currency;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsCurrency else
+ Result := 0.0;
+end;
+
+function TSuperTableString.GetD(const k: SOString): Double;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsDouble else
+ Result := 0.0;
+end;
+
+procedure TSuperTableString.PutB(const k: SOString; value: Boolean);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+function TSuperTableString.GetB(const k: SOString): Boolean;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsBoolean else
+ Result := False;
+end;
+
+{$IFDEF SUPER_METHOD}
+procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperTableString.GetM(const k: SOString): TSuperMethod;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsMethod else
+ Result := nil;
+end;
+{$ENDIF}
+
+procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject);
+begin
+ if value <> nil then
+ PutO(k, TSuperObject.Create(stNull)) else
+ PutO(k, value);
+end;
+
+function TSuperTableString.GetN(const k: SOString): ISuperObject;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj else
+ Result := TSuperObject.Create(stNull);
+end;
+
+
+{$IFDEF VER210}
+
+{ TSuperAttribute }
+
+constructor TSuperAttribute.Create(const AName: string);
+begin
+ FName := AName;
+end;
+
+{ TSuperRttiContext }
+
+constructor TSuperRttiContext.Create;
+begin
+ Context := TRttiContext.Create;
+ SerialFromJson := TDictionary.Create;
+ SerialToJson := TDictionary.Create;
+
+ SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean);
+ SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime);
+ SerialFromJson.Add(TypeInfo(TGUID), serialfromguid);
+ SerialToJson.Add(TypeInfo(Boolean), serialtoboolean);
+ SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime);
+ SerialToJson.Add(TypeInfo(TGUID), serialtoguid);
+end;
+
+destructor TSuperRttiContext.Destroy;
+begin
+ SerialFromJson.Free;
+ SerialToJson.Free;
+ Context.Free;
+end;
+
+class function TSuperRttiContext.GetFieldName(r: TRttiField): string;
+var
+ o: TCustomAttribute;
+begin
+ for o in r.GetAttributes do
+ if o is SOName then
+ Exit(SOName(o).Name);
+ Result := r.Name;
+end;
+
+class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
+var
+ o: TCustomAttribute;
+begin
+ if not ObjectIsType(obj, stNull) then Exit(obj);
+ for o in r.GetAttributes do
+ if o is SODefault then
+ Exit(SO(SODefault(o).Name));
+ Result := obj;
+end;
+
+function TSuperRttiContext.AsType(const obj: ISuperObject): T;
+var
+ ret: TValue;
+begin
+ if FromJson(TypeInfo(T), obj, ret) then
+ Result := ret.AsType else
+ raise exception.Create('Marshalling error');
+end;
+
+function TSuperRttiContext.AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject;
+var
+ v: TValue;
+begin
+ TValue.MakeWithoutCopy(@obj, TypeInfo(T), v);
+ if index <> nil then
+ Result := ToJson(v, index) else
+ Result := ToJson(v, so);
+end;
+
+function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject;
+ var Value: TValue): Boolean;
+
+ procedure FromChar;
+ begin
+ if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
+ begin
+ Value := string(AnsiString(obj.AsString)[1]);
+ Result := True;
+ end else
+ Result := False;
+ end;
+
+ procedure FromWideChar;
+ begin
+ if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
+ begin
+ Value := obj.AsString[1];
+ Result := True;
+ end else
+ Result := False;
+ end;
+
+ procedure FromInt64;
+ var
+ i: Int64;
+ begin
+ case ObjectGetType(obj) of
+ stInt:
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ TValueData(Value).FAsSInt64 := obj.AsInteger;
+ Result := True;
+ end;
+ stString:
+ begin
+ if TryStrToInt64(obj.AsString, i) then
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ TValueData(Value).FAsSInt64 := i;
+ Result := True;
+ end else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ end;
+
+ procedure FromInt(const obj: ISuperObject);
+ var
+ TypeData: PTypeData;
+ i: Integer;
+ o: ISuperObject;
+ begin
+ case ObjectGetType(obj) of
+ stInt, stBoolean:
+ begin
+ i := obj.AsInteger;
+ TypeData := GetTypeData(TypeInfo);
+ Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue);
+ if Result then
+ TValue.Make(@i, TypeInfo, Value);
+ end;
+ stString:
+ begin
+ o := SO(obj.AsString);
+ if not ObjectIsType(o, stString) then
+ FromInt(o) else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ end;
+
+ procedure fromSet;
+ begin
+ if ObjectIsType(obj, stInt) then
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ TValueData(Value).FAsSLong := obj.AsInteger;
+ Result := True;
+ end else
+ Result := False;
+ end;
+
+ procedure FromFloat(const obj: ISuperObject);
+ var
+ o: ISuperObject;
+ begin
+ case ObjectGetType(obj) of
+ stInt, stDouble, stCurrency:
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ case GetTypeData(TypeInfo).FloatType of
+ ftSingle: TValueData(Value).FAsSingle := obj.AsDouble;
+ ftDouble: TValueData(Value).FAsDouble := obj.AsDouble;
+ ftExtended: TValueData(Value).FAsExtended := obj.AsDouble;
+ ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger;
+ ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency;
+ end;
+ Result := True;
+ end;
+ stString:
+ begin
+ o := SO(obj.AsString);
+ if not ObjectIsType(o, stString) then
+ FromFloat(o) else
+ Result := False;
+ end
+ else
+ Result := False;
+ end;
+ end;
+
+ procedure FromString;
+ begin
+ case ObjectGetType(obj) of
+ stObject, stArray:
+ Result := False;
+ stnull:
+ begin
+ Value := '';
+ Result := True;
+ end;
+ else
+ Value := obj.AsString;
+ Result := True;
+ end;
+ end;
+
+ procedure FromClass;
+ var
+ f: TRttiField;
+ v: TValue;
+ begin
+ case ObjectGetType(obj) of
+ stObject:
+ begin
+ Result := True;
+ if Value.Kind <> tkClass then
+ Value := GetTypeData(TypeInfo).ClassType.Create;
+ for f in Context.GetType(Value.AsObject.ClassType).GetFields do
+ if f.FieldType <> nil then
+ begin
+ Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
+ if Result then
+ f.SetValue(Value.AsObject, v) else
+ Exit;
+ end;
+ end;
+ stNull:
+ begin
+ Value := nil;
+ Result := True;
+ end
+ else
+ // error
+ Value := nil;
+ Result := False;
+ end;
+ end;
+
+ procedure FromRecord;
+ var
+ f: TRttiField;
+ p: Pointer;
+ v: TValue;
+ begin
+ Result := True;
+ TValue.Make(nil, TypeInfo, Value);
+ for f in Context.GetType(TypeInfo).GetFields do
+ begin
+ if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then
+ begin
+ p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData;
+ Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
+ if Result then
+ f.SetValue(p, v) else
+ Exit;
+ end else
+ begin
+ Result := False;
+ Exit;
+ end;
+ end;
+ end;
+
+ procedure FromDynArray;
+ var
+ i: Integer;
+ p: Pointer;
+ pb: PByte;
+ val: TValue;
+ typ: PTypeData;
+ el: PTypeInfo;
+ begin
+ case ObjectGetType(obj) of
+ stArray:
+ begin
+ i := obj.AsArray.Length;
+ p := nil;
+ DynArraySetLength(p, TypeInfo, 1, @i);
+ pb := p;
+ typ := GetTypeData(TypeInfo);
+ if typ.elType <> nil then
+ el := typ.elType^ else
+ el := typ.elType2^;
+
+ Result := True;
+ for i := 0 to i - 1 do
+ begin
+ Result := FromJson(el, obj.AsArray[i], val);
+ if not Result then
+ Break;
+ val.ExtractRawData(pb);
+ val := TValue.Empty;
+ Inc(pb, typ.elSize);
+ end;
+ if Result then
+ TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
+ DynArrayClear(p, TypeInfo);
+ end;
+ stNull:
+ begin
+ TValue.MakeWithoutCopy(nil, TypeInfo, Value);
+ Result := True;
+ end;
+ else
+ i := 1;
+ p := nil;
+ DynArraySetLength(p, TypeInfo, 1, @i);
+ pb := p;
+ typ := GetTypeData(TypeInfo);
+ if typ.elType <> nil then
+ el := typ.elType^ else
+ el := typ.elType2^;
+
+ Result := FromJson(el, obj, val);
+ val.ExtractRawData(pb);
+ val := TValue.Empty;
+
+ if Result then
+ TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
+ DynArrayClear(p, TypeInfo);
+ end;
+ end;
+
+ procedure FromArray;
+ var
+ ArrayData: PArrayTypeData;
+ idx: Integer;
+ function ProcessDim(dim: Byte; const o: ISuperobject): Boolean;
+ var
+ i: Integer;
+ v: TValue;
+ a: PTypeData;
+ begin
+ if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then
+ begin
+ a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData;
+ if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then
+ begin
+ Result := False;
+ Exit;
+ end;
+ Result := True;
+ if dim = ArrayData.DimCount then
+ for i := a.MinValue to a.MaxValue do
+ begin
+ Result := FromJson(ArrayData.ElType^, o.AsArray[i], v);
+ if not Result then
+ Exit;
+ Value.SetArrayElement(idx, v);
+ inc(idx);
+ end
+ else
+ for i := a.MinValue to a.MaxValue do
+ begin
+ Result := ProcessDim(dim + 1, o.AsArray[i]);
+ if not Result then
+ Exit;
+ end;
+ end else
+ Result := False;
+ end;
+ var
+ i: Integer;
+ v: TValue;
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ ArrayData := @GetTypeData(TypeInfo).ArrayData;
+ idx := 0;
+ if ArrayData.DimCount = 1 then
+ begin
+ if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then
+ begin
+ Result := True;
+ for i := 0 to ArrayData.ElCount - 1 do
+ begin
+ Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v);
+ if not Result then
+ Exit;
+ Value.SetArrayElement(idx, v);
+ v := TValue.Empty;
+ inc(idx);
+ end;
+ end else
+ Result := False;
+ end else
+ Result := ProcessDim(1, obj);
+ end;
+
+ procedure FromClassRef;
+ var
+ r: TRttiType;
+ begin
+ if ObjectIsType(obj, stString) then
+ begin
+ r := Context.FindType(obj.AsString);
+ if r <> nil then
+ begin
+ Value := TRttiInstanceType(r).MetaclassType;
+ Result := True;
+ end else
+ Result := False;
+ end else
+ Result := False;
+ end;
+
+ procedure FromUnknown;
+ begin
+ case ObjectGetType(obj) of
+ stBoolean:
+ begin
+ Value := obj.AsBoolean;
+ Result := True;
+ end;
+ stDouble:
+ begin
+ Value := obj.AsDouble;
+ Result := True;
+ end;
+ stCurrency:
+ begin
+ Value := obj.AsCurrency;
+ Result := True;
+ end;
+ stInt:
+ begin
+ Value := obj.AsInteger;
+ Result := True;
+ end;
+ stString:
+ begin
+ Value := obj.AsString;
+ Result := True;
+ end
+ else
+ Value := nil;
+ Result := False;
+ end;
+ end;
+
+ procedure FromInterface;
+ const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}';
+ var
+ o: ISuperObject;
+ begin
+ if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then
+ begin
+ if obj <> nil then
+ TValue.Make(@obj, TypeInfo, Value) else
+ begin
+ o := TSuperObject.Create(stNull);
+ TValue.Make(@o, TypeInfo, Value);
+ end;
+ Result := True;
+ end else
+ Result := False;
+ end;
+var
+ Serial: TSerialFromJson;
+begin
+ if TypeInfo <> nil then
+ begin
+ if not SerialFromJson.TryGetValue(TypeInfo, Serial) then
+ case TypeInfo.Kind of
+ tkChar: FromChar;
+ tkInt64: FromInt64;
+ tkEnumeration, tkInteger: FromInt(obj);
+ tkSet: fromSet;
+ tkFloat: FromFloat(obj);
+ tkString, tkLString, tkUString, tkWString: FromString;
+ tkClass: FromClass;
+ tkMethod: ;
+ tkWChar: FromWideChar;
+ tkRecord: FromRecord;
+ tkPointer: ;
+ tkInterface: FromInterface;
+ tkArray: FromArray;
+ tkDynArray: FromDynArray;
+ tkClassRef: FromClassRef;
+ else
+ FromUnknown
+ end else
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ Result := Serial(Self, obj, Value);
+ end;
+ end else
+ Result := False;
+end;
+
+function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject;
+ procedure ToInt64;
+ begin
+ Result := TSuperObject.Create(SuperInt(Value.AsInt64));
+ end;
+
+ procedure ToChar;
+ begin
+ Result := TSuperObject.Create(string(Value.AsType));
+ end;
+
+ procedure ToInteger;
+ begin
+ Result := TSuperObject.Create(TValueData(Value).FAsSLong);
+ end;
+
+ procedure ToFloat;
+ begin
+ case Value.TypeData.FloatType of
+ ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle);
+ ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble);
+ ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended);
+ ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64);
+ ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr);
+ end;
+ end;
+
+ procedure ToString;
+ begin
+ Result := TSuperObject.Create(string(Value.AsType));
+ end;
+
+ procedure ToClass;
+ var
+ o: ISuperObject;
+ f: TRttiField;
+ v: TValue;
+ begin
+ if TValueData(Value).FAsObject <> nil then
+ begin
+ o := index[IntToStr(Integer(Value.AsObject))];
+ if o = nil then
+ begin
+ Result := TSuperObject.Create(stObject);
+ index[IntToStr(Integer(Value.AsObject))] := Result;
+ for f in Context.GetType(Value.AsObject.ClassType).GetFields do
+ if f.FieldType <> nil then
+ begin
+ v := f.GetValue(Value.AsObject);
+ Result.AsObject[GetFieldName(f)] := ToJson(v, index);
+ end
+ end else
+ Result := o;
+ end else
+ Result := nil;
+ end;
+
+ procedure ToWChar;
+ begin
+ Result := TSuperObject.Create(string(Value.AsType));
+ end;
+
+ procedure ToVariant;
+ begin
+ Result := SO(Value.AsVariant);
+ end;
+
+ procedure ToRecord;
+ var
+ f: TRttiField;
+ v: TValue;
+ begin
+ Result := TSuperObject.Create(stObject);
+ for f in Context.GetType(Value.TypeInfo).GetFields do
+ begin
+ v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData);
+ Result.AsObject[GetFieldName(f)] := ToJson(v, index);
+ end;
+ end;
+
+ procedure ToArray;
+ var
+ idx: Integer;
+ ArrayData: PArrayTypeData;
+
+ procedure ProcessDim(dim: Byte; const o: ISuperObject);
+ var
+ dt: PTypeData;
+ i: Integer;
+ o2: ISuperObject;
+ v: TValue;
+ begin
+ if ArrayData.Dims[dim-1] = nil then Exit;
+ dt := GetTypeData(ArrayData.Dims[dim-1]^);
+ if Dim = ArrayData.DimCount then
+ for i := dt.MinValue to dt.MaxValue do
+ begin
+ v := Value.GetArrayElement(idx);
+ o.AsArray.Add(toJSon(v, index));
+ inc(idx);
+ end
+ else
+ for i := dt.MinValue to dt.MaxValue do
+ begin
+ o2 := TSuperObject.Create(stArray);
+ o.AsArray.Add(o2);
+ ProcessDim(dim + 1, o2);
+ end;
+ end;
+ var
+ i: Integer;
+ v: TValue;
+ begin
+ Result := TSuperObject.Create(stArray);
+ ArrayData := @Value.TypeData.ArrayData;
+ idx := 0;
+ if ArrayData.DimCount = 1 then
+ for i := 0 to ArrayData.ElCount - 1 do
+ begin
+ v := Value.GetArrayElement(i);
+ Result.AsArray.Add(toJSon(v, index))
+ end
+ else
+ ProcessDim(1, Result);
+ end;
+
+ procedure ToDynArray;
+ var
+ i: Integer;
+ v: TValue;
+ begin
+ Result := TSuperObject.Create(stArray);
+ for i := 0 to Value.GetArrayLength - 1 do
+ begin
+ v := Value.GetArrayElement(i);
+ Result.AsArray.Add(toJSon(v, index));
+ end;
+ end;
+
+ procedure ToClassRef;
+ begin
+ if TValueData(Value).FAsClass <> nil then
+ Result := TSuperObject.Create(string(
+ TValueData(Value).FAsClass.UnitName + '.' +
+ TValueData(Value).FAsClass.ClassName)) else
+ Result := nil;
+ end;
+
+ procedure ToInterface;
+ begin
+ if TValueData(Value).FHeapData <> nil then
+ TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else
+ Result := nil;
+ end;
+
+var
+ Serial: TSerialToJson;
+begin
+ if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then
+ case Value.Kind of
+ tkInt64: ToInt64;
+ tkChar: ToChar;
+ tkSet, tkInteger, tkEnumeration: ToInteger;
+ tkFloat: ToFloat;
+ tkString, tkLString, tkUString, tkWString: ToString;
+ tkClass: ToClass;
+ tkWChar: ToWChar;
+ tkVariant: ToVariant;
+ tkRecord: ToRecord;
+ tkArray: ToArray;
+ tkDynArray: ToDynArray;
+ tkClassRef: ToClassRef;
+ tkInterface: ToInterface;
+ else
+ result := nil;
+ end else
+ Result := Serial(Self, value, index);
+end;
+
+{ TSuperObjectHelper }
+
+constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil);
+var
+ v: TValue;
+ ctxowned: Boolean;
+begin
+ if ctx = nil then
+ begin
+ ctx := TSuperRttiContext.Create;
+ ctxowned := True;
+ end else
+ ctxowned := False;
+ try
+ v := Self;
+ if not ctx.FromJson(v.TypeInfo, obj, v) then
+ raise Exception.Create('Invalid object');
+ finally
+ if ctxowned then
+ ctx.Free;
+ end;
+end;
+
+constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil);
+begin
+ FromJson(SO(str), ctx);
+end;
+
+function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
+var
+ v: TValue;
+ ctxowned: boolean;
+begin
+ if ctx = nil then
+ begin
+ ctx := TSuperRttiContext.Create;
+ ctxowned := True;
+ end else
+ ctxowned := False;
+ try
+ v := Self;
+ Result := ctx.ToJson(v, SO);
+ finally
+ if ctxowned then
+ ctx.Free;
+ end;
+end;
+
+{$ENDIF}
+
+{$IFDEF DEBUG}
+initialization
+
+finalization
+ Assert(debugcount = 0, 'Memory leak');
+{$ENDIF}
+end.
+
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/uJSON.pas" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/uJSON.pas"
new file mode 100644
index 0000000..4ccdf95
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/uJSON.pas"
@@ -0,0 +1,4389 @@
+{
+ Copyright (C) 2005 Fabio Almeida
+ fabiorecife@yahoo.com.br
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ Autor : Jose Fabio Nascimento de Almeida
+ Data : 7/11/2005
+
+
+Change Logs:
+2013-11-04 By yangyxd
+ parent, child֧֡int64֧
+
+2009-11-22 By creation_zy
+ Can parse #10 #13 inside a string.
+ JSONObject.quote method can deal with special character smaller than space.
+ Value inside a _String object can Read/Write directly.
+
+2011-09-02 By creation_zy
+ Add _Object to store common Object.
+
+2011-09-20 By creation_zy
+ Add SafeFreeJObj.
+ Add "inline" directive.
+
+2011-12-15 By creation_zy
+ Add SpaceStr function to optimize toString3.
+}
+unit uJSON;
+
+interface
+
+uses
+ Windows,SysUtils, Classes, TypInfo;
+
+{$DEFINE J_OBJECT} // store common Object
+{$IF COMPILERVERSION>=18}{$DEFINE INLINE_OPT}{$IFEND}
+{$DEFINE BACK_OPT}
+{$DEFINE NEXT_OPT}
+
+
+Type
+ JSONArray = class ;
+ JSONBase = class;
+ JSONObject = class;
+
+ TZAbstractObject = class (TObject)
+ class procedure WriteChar(avOut: TStream; const avData: Char);
+ class procedure WriteString(avOut: TStream; const avData: string);
+ class procedure WriteText(avOut: TStream; const avData: string; len: Integer);
+
+ function Equals(const Value: TZAbstractObject): Boolean; virtual;
+ function Hash: LongInt;
+ function Clone: TZAbstractObject; virtual;
+ function toString: string; virtual;
+ function toJSONObject: JSONObject;
+ function toJSONArray: JSONArray;
+ function instanceOf(const Value: TZAbstractObject): Boolean;
+ procedure SaveToStream(stream: TStream); virtual;
+ class function getInt(o: TZAbstractObject; DefaultValue: Integer):Integer;
+ class function getInt64(o: TZAbstractObject; DefaultValue: Int64): Int64;
+ class function getDouble(o: TZAbstractObject; DefaultValue: Double):Double;
+ class function getBoolean(o: TZAbstractObject; DefaultValue: Boolean):Boolean;
+ procedure Free; overload; //2011-10-10 Call SafeFreeJObj
+ end;
+
+ ClassCastException = class (Exception) end;
+ NoSuchElementException = class (Exception) end;
+ NumberFormatException = class (Exception) end;
+ NullPointerException = class (Exception) end;
+ NotImplmentedFeature = class (Exception) end;
+ _Number = class ;
+ _String = class;
+ _Double = class;
+ _NULL = class ;
+{$IFDEF J_OBJECT}
+ _Object = class; //2011-08-09
+{$ENDIF}
+
+
+ ParseException = class (Exception)
+ constructor create (_message: string ; index: integer);
+ end;
+ JSONTokener = class (TZAbstractObject)
+ public
+ constructor create (const s: string);
+ procedure back();{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ class function dehexchar(c: char) :integer;
+ function more :boolean;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function next(): char; overload ;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function next (c:char ): char; overload ;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function next (n:integer): string; overload ;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function nextClean (): char;//{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function nextString (quote: char): string;//{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function nextTo (d: char): string; overload ;
+ function nextTo (const delimiters: string): char; overload ;
+ function nextValue (parent: JSONBase): TZAbstractObject ;//{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ procedure skipPast (const _to: string ) ;
+ function skipTo (_to: char ): char;
+ function syntaxError (const _message: string): ParseException;
+ function toString: string; override;
+ function unescape (const s: string): string;
+ private
+ myIndex, Len1: integer;
+ mySource: string;
+ end;
+
+ // by yangyxd 2013.11.04
+ JSONBase = class(TZAbstractObject)
+ private
+ FParent: JSONBase;
+ FName: string;
+ protected
+ function GetCount: Integer; virtual;
+ function GetChild(Index: Integer): TZAbstractObject; virtual;
+ procedure SetChild(Index: Integer; const Value: TZAbstractObject); virtual;
+ public
+ constructor Create;
+ function IndexOfObject(aobj: TObject): Integer; virtual;
+ property Count: Integer read GetCount;
+ property Parent: JSONBase read FParent write FParent;
+ property Name: string read FName write FName;
+ property Child[Index: Integer]: TZAbstractObject read GetChild write SetChild;
+ end;
+
+ JSONObject = class (JSONBase)
+ private
+ myHashMap: TStringList;
+ function GetPropValues(const Key: String): String;
+ procedure SetPropValues(const Key: String; const Value: String);
+ procedure SetAsString(const Value: String);
+ function GetKeyByIndex(index: Integer): String;
+ procedure SetCascadeValueEx(const Value: String; const Keys: array of String;
+ StartIdx: Integer);
+ function GetValByIndex(index: Integer): String;
+ procedure UpdateByTokener(x: JSONTokener);
+ function GetValObjByIndex(index: Integer): TZAbstractObject;
+ protected
+ function GetCount: Integer; override; // by yangyxd
+ function GetChild(Index: Integer): TZAbstractObject; override; // by yangyxd
+ procedure SetChild(Index: Integer; const Value: TZAbstractObject); override; // by yangyxd
+ public
+ constructor Create; overload;
+ constructor Create (jo: JSONObject; sa: array of string); overload;
+ constructor Create (x: JSONTokener); overload;
+ constructor Create (map: TStringList); overload;
+ constructor Create (const s: string); overload;
+ constructor CreateInArray(Ay: JSONArray);
+
+ function IndexOfObject(aobj: TObject): Integer; override; // by yangyxd
+
+ procedure Clean;
+ function Clone: TZAbstractObject; override;
+ function Accumulate (const key: string; value: TZAbstractObject): JSONObject;
+ function Get (const key: string): TZAbstractObject;
+ function GetBoolean (const key: string): boolean;
+ function GetDouble (const key: string): double;
+ function GetInt (const key: string): integer;
+ function GetInt64 (const key: string): Int64;
+ function GetJSONArray (const key: string) :JSONArray;
+ function GetJSONObject (const key: string): JSONObject;
+ function GetString (const key: string): string;
+ function Has (const key: string): boolean;
+ function IsNull (const key: string): boolean;
+ function Keys: TStringList ;
+ function Length: integer;
+ function Names: JSONArray;
+ class function NumberToString (n: _Number): string;
+ class function ValueToString(value: TZAbstractObject): string; overload;
+ class procedure ValueToStream(value: TZAbstractObject; stream: TStream); overload;
+ class function ValueToString(value: TZAbstractObject;
+ indentFactor, indent: integer): string; overload;
+
+ function NextSibling: JSONObject;
+ function UpSibling: JSONObject;
+
+ function Opt (const key: string): TZAbstractObject;
+ function OptBoolean (const key: string): boolean; overload;
+ function OptBoolean (const key: string; defaultValue: boolean): boolean; overload;
+ function OptDouble (const key: string): double; overload;
+ function OptDouble (const key: string; defaultValue: double): double; overload;
+ function OptInt (const key: string): integer; overload;
+ function OptInt (const key: string; defaultValue: integer): integer; overload;
+ function OptInt64 (const key: string): int64; overload;
+ function OptInt64 (const key: string; defaultValue: int64): int64; overload;
+ function OptString (const key: string): string; overload;
+ function OptString (const key, defaultValue: string): string; overload;
+
+ function OptJSONArray (const key: string): JSONArray; overload;
+ function OptJSONObject (const key: string): JSONObject; overload;
+
+ function Put (const key: string; value: boolean): JSONObject; overload;
+ function Put (const key: string; value: double): JSONObject; overload;
+ function Put (const key: string; value: integer): JSONObject; overload;
+ function Put (const key: string; value: int64): JSONObject; overload;
+ function Put (const key: string; const value: string): JSONObject; overload;
+ function Put (const key: string; value: TZAbstractObject): JSONObject; overload;
+
+ function PutOpt (const key: string; value: TZAbstractObject): JSONObject;
+ class function quote (const s: string): string;
+ class procedure quoteToStream (stream: TStream; const s: string);
+ function Remove (const key: string): TZAbstractObject;
+ procedure AssignTo(json: JSONObject);
+
+ function ToJSONArray (names: JSONArray): JSONArray;
+ function toString (): string ; overload; override;
+ function toString2 (indentFactor: integer): string; overload;
+ function toString3 (indentFactor, indent: integer): string; overload;
+
+ procedure SaveToStream(stream: TStream); override;
+
+ //Add by creation_zy 2008-10-21
+ property PropValues[const Key: String]:String read GetPropValues write SetPropValues; default;
+ property KeyByIndex[index: Integer]:String read GetKeyByIndex;
+ property ValByIndex[index: Integer]:String read GetValByIndex;
+ property ValObjByIndex[index: Integer]:TZAbstractObject read GetValObjByIndex;
+ property AsString:String read ToString write SetAsString;
+ procedure Assign(Source: JSONObject);
+ function Opt2(key, key2: string): TZAbstractObject;
+ function OptString2(key, key2: String; DefaultValue: String=''): String;
+ function OptInt2(key, key2: String; DefaultValue: Integer=0): Integer;
+ function GetCascadeValue(const Keys: array of String): String;
+ procedure SetCascadeValue(const Value: String; const Keys: array of String);
+ function GetCascadeValEx(const Keys: array of String): String;
+ function GetCascadeValObj(const Keys: array of String): TZAbstractObject;
+ function GetDiffFrom(Source: JSONObject; UseSrc: Boolean=true):JSONObject;
+ procedure Delete(index: Integer);
+ procedure RemoveByKeyHeader(const Header: String='~');
+ function RemoveLastKey:TZAbstractObject;
+ procedure CleanKey(const Key: String);
+ function SetKey(idx: Integer; const Key: String):Boolean;
+ function PropCount:Integer;
+ function KeyByVal(const Value: String):String;
+ function PartExtract(KeyNames: TStrings; DoRemove: Boolean):JSONObject;
+ function ExtractAll:JSONObject;
+ function TryNewJSONArray(const Key: String):JSONArray;
+ function TryNewJSONObject(const Key: String):JSONObject;
+ //Add by creation_zy 2011-08-09
+ {$IFDEF J_OBJECT}
+ function GetObject (const key: string): TObject;
+ function OptObject (const key: string): TObject; overload;
+ function OptObject (const key: string; defaultValue: TObject): TObject; overload;
+ function Put (const key: string; value: TObject): JSONObject; overload;
+ {$ENDIF}
+
+ destructor Destroy;override;
+ class function NULL: _NULL;
+ end;
+
+ JSONArray = class (JSONBase)
+ public
+ destructor Destroy ; override;
+ constructor Create ; overload;
+ constructor Create (collection: TList); overload;
+ constructor Create (x: JSONTokener); overload;
+ constructor Create (const s: string); overload;
+
+ procedure Clean; //by creation_zy 2009-08-19
+ function Clone: TZAbstractObject; override; //by creation_zy 2008-10-05
+ function get (index: integer): TZAbstractObject;
+ function getBoolean (index: integer): boolean;
+ function getDouble (index: integer): double;
+ function getInt (index: integer): integer;
+ function getInt64 (index: integer): int64;
+ function getJSONArray (index: integer): JSONArray;
+ function getJSONObject (index: integer): JSONObject;
+ function getString (index: integer): string;
+ function isNull (index: integer): boolean;
+ function join (separator: string): string;
+ function length: integer;
+ function opt (index: integer): TZAbstractObject;
+ function optBoolean ( index: integer): boolean; overload;
+ function optBoolean ( index: integer; defaultValue: boolean): boolean; overload;
+ function optDouble (index: integer): double; overload;
+ function optDouble (index: integer; defaultValue :double ): double ; overload;
+ function optInt (index: integer): integer; overload;
+ function optInt (index: integer; defaultValue: integer): integer; overload;
+ function OptInt64 (index: integer): int64; overload;
+ function OptInt64 (index: integer; defaultValue: int64): int64; overload;
+ function optJSONArray (index: integer): JSONArray ; overload;
+ function optJSONObject (index: integer): JSONObject ; overload;
+ function optString (index: integer): string; overload;
+ function optString (index: integer; defaultValue: string): string; overload;
+ {$IFDEF J_OBJECT}
+ function optObject (index: integer): TObject; overload;
+ {$ENDIF}
+ function put ( value: boolean): JSONArray; overload ;
+ function put ( value: double ): JSONArray; overload ;
+ function put ( value: integer): JSONArray; overload ;
+ function put ( value: TZAbstractObject): JSONArray; overload ;
+ function put ( value: string): JSONArray; overload;
+ {$IFDEF J_OBJECT}
+ function put ( value: TObject): JSONArray; overload;
+ {$ENDIF}
+ function put ( index: integer ; value: boolean): JSONArray; overload ;
+ function put ( index: integer ; value: double): JSONArray; overload ;
+ function put ( index: integer ; value: integer): JSONArray; overload ;
+ function put ( index: integer ; value: int64): JSONArray; overload ;
+ function put ( index: integer ; value: TZAbstractObject): JSONArray; overload ;
+ function put ( index: integer; value: string): JSONArray; overload;
+ {$IFDEF J_OBJECT}
+ function put ( index: integer ; value: TObject): JSONArray; overload;
+ {$ENDIF}
+ function LastItem: TZAbstractObject;
+ function toJSONObject (names :JSONArray ): JSONObject ; overload ;
+ function toString: string; overload; override;
+ function toString2 (indentFactor: integer): string; overload;
+ function toString3 (indentFactor, indent: integer): string; overload;
+ function toList (): TList;
+ function appendJSONArray( value: JSONArray): Integer ; //2008-10-08
+ procedure Assign( Source: JSONArray);
+
+ function IndexOfObject(aobj: TObject): Integer; override; // by yangyxd
+ private
+ myArrayList: TList;
+ protected
+ function GetCount: Integer; override; // by yangyxd
+ function GetChild(Index: Integer): TZAbstractObject; override; // by yangyxd
+ procedure SetChild(Index: Integer; const Value: TZAbstractObject); override; // by yangyxd
+ end;
+
+
+ _Number = class (TZAbstractObject)
+ public
+ function doubleValue: double; virtual; abstract;
+ function intValue: integer; virtual; abstract;
+ function int64Value: Int64; virtual; abstract; // by yangyxd
+ end;
+
+ _Boolean = class (TZAbstractObject)
+ public
+ class function _TRUE (): _Boolean;
+ class function _FALSE (): _Boolean;
+ class function valueOf (b: boolean): _Boolean;
+ constructor create (b: boolean);
+ function boolValue: Boolean; //By creation_zy 2008-10-06
+ function toString (): string; override;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: boolean;
+ end;
+
+ _Double = class (_Number)
+ constructor create (const s: string); overload;
+ constructor create (s: _String); overload;
+ constructor create (d: double); overload;
+ function doubleValue: double; override;
+ function intValue: integer; override;
+ function int64Value: Int64; override;
+ function toString (): string ; override;
+ class function NaN: double;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: double;
+ end;
+
+ _Integer = class (_Number)
+ class function parseInt64 (const s: string): int64; overload;
+ class function parseInt64 (s: _String): int64; overload;
+ class function parseInt (const s: string; i: integer): integer; overload;
+ class function parseInt (s: _String): integer; overload;
+ class function toHexString (c: char): string;
+ constructor create (i: integer); overload;
+ constructor create (i: int64); overload;
+ constructor create (const s: string); overload;
+ function doubleValue: double; override;
+ function intValue: integer; override;
+ function int64Value: Int64; override;
+ function toString (): string; override;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: int64;
+ end;
+
+ _String = class (TZAbstractObject)
+ private
+ function GetAsString: String;
+ procedure SetAsString(const Value: String);
+ public
+ constructor create (const s: string);
+ function equalsIgnoreCase (const s: string): boolean;
+ function Equals(const Value: TZAbstractObject): Boolean; override;
+ function toString(): string; override;
+ function Clone :TZAbstractObject; override;
+ property AsString: String read GetAsString write SetAsString; //By creation_zy 2009-11-22
+ private
+ fvalue: string;
+ end;
+
+ _NULL = class (TZAbstractObject)
+ function Equals(const Value: TZAbstractObject): Boolean; override;
+ function toString(): string; override;
+ function Clone :TZAbstractObject; override; //By creation_zy 2009-12-11
+ end;
+
+{$IFDEF J_OBJECT}
+ _Object = class (TZAbstractObject)
+ function Equals(const Value: TZAbstractObject): Boolean; override;
+ function toString(): string; override;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: TObject;
+ constructor Create(value: TObject);
+ procedure SetAsObject(const Value: TObject);
+ public
+ property AsObject: TObject read fvalue write SetAsObject;
+ end;
+{$ENDIF}
+
+ TJObjTransFlag=(jtfDbQouteStr, jtfQouteStr, jtfOtherAsStr);
+ TJObjTransFlags=set of TJObjTransFlag;
+
+function HexToInt(const S: String):Integer;
+function IsConstJSON(Z: TObject):Boolean;
+procedure SafeFreeJObj(Z: TObject);{$IF COMPILERVERSION>=18}inline;{$IFEND}
+function SpaceStr(ALen: Integer):String;
+function StrToAbstractJObj(const Str: String; Flags: TJObjTransFlags=[jtfDbQouteStr, jtfQouteStr]):TZAbstractObject;
+
+// by yangyxd 2013.11.06
+function JsonGetAttribute(const JSON, Name: string): string;
+function JsonGetAttributeAsInt(const JSON, Name: string): Integer;
+function JsonGetAttributeAsDouble(const JSON, Name: string): double;
+
+var
+ gcLista: TList;
+ CNULL: _NULL;
+ //Set this var to ture to force unicode char (eg: Chinese...) output in the form of \uXXXX
+ UnicodeOutput: Boolean=false;
+ SimpleJSON: Boolean=false; //2012-08-03
+
+implementation
+
+//{$D-}
+
+const
+ CROTINA_NAO_IMPLEMENTADA :string = 'Not imp';
+var
+ CONST_FALSE: _Boolean;
+ CONST_TRUE: _Boolean;
+
+//By creation_zy
+function IsSimpString(const Str:String):Boolean;
+var
+ i:Integer;
+begin
+ Result:=true;
+ for i:=1 to Length(Str) do
+ begin
+ Result:=Str[i] in ['0'..'9','a'..'z','A'..'Z','_'];
+ if not Result then exit;
+ end;
+end;
+
+//By creation_zy
+function SingleHZToJSONCode(const HZ:String):String;
+var
+ wstr:WideString;
+begin
+ if HZ='' then
+ begin
+ Result:='';
+ exit;
+ end;
+ wstr:=WideString(HZ);
+ Result:='\u'+IntToHex(PWord(@wstr[1])^,4);
+end;
+
+//By creation_zy 2009-11-21
+function IsConstJSON(Z: TObject):Boolean;
+begin
+ Result:=(Z=CNULL) or (Z=CONST_FALSE) or (Z=CONST_TRUE);
+end;
+
+procedure SafeFreeJObj(Z: TObject);
+begin
+ if not IsConstJSON(Z) then
+ Z.Free;
+end;
+
+function SpaceStr(ALen: Integer): string; {$IFDEF INLINE_OPT}inline;{$ENDIF}
+begin
+ if ALen > 0 then begin
+ SetLength(Result, ALen);
+ FillChar(Result[1], ALen, ' ');
+ end else Result := '';
+end;
+
+procedure newNotImplmentedFeature () ;
+begin
+ raise NotImplmentedFeature.create (CROTINA_NAO_IMPLEMENTADA);
+end;
+
+function getFormatSettings: TFormatSettings ;
+var
+ f: TFormatSettings;
+begin
+ {$IFDEF MSWINDOWS}
+ SysUtils.GetLocaleFormatSettings (Windows.GetThreadLocale,f);
+ {$ELSE}
+ newNotImplmentedFeature();
+ {$ENDIF}
+ Result:=f;
+ Result.DecimalSeparator:='.';
+ Result.ThousandSeparator:=',';
+end;
+
+
+function HexToInt(const S: String): Integer;
+const HexMap:array [Char] of SmallInt =
+ (
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1,
+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
+ );
+var
+ i, n, l: Integer;
+begin
+ Result:=0;
+ l:=Length(S);
+ if l=0 then exit;
+ if S[1]='$' then
+ n:=2
+ else if (l>=2) and (S[2] in ['x','X']) then
+ n:=3
+ else
+ n:=1;
+ for i:=n to l do
+ Result:=Result*16+HexMap[S[i]];
+end;
+
+function StrToAbstractJObj(const Str: String; Flags: TJObjTransFlags):TZAbstractObject;
+var
+ i:Integer;
+begin
+ if Str<>'' then
+ begin
+ case Str[1] of
+ '{':
+ begin
+ try
+ Result:=JSONObject.Create(Str);
+ except
+ Result:=nil;
+ end;
+ exit;
+ end;
+ '[':
+ begin
+ try
+ Result:=JSONArray.Create(Str);
+ except
+ Result:=nil;
+ end;
+ exit;
+ end;
+ '0'..'9','.','-':
+ begin
+ try
+ i:=StrToInt(Str);
+ Result:=_Integer.Create(i);
+ except
+ Result:=_Double.Create(StrToFloatDef(Str,0));
+ end;
+ exit;
+ end;
+ 'n':
+ begin
+ if Str='null' then
+ begin
+ Result:=CNull;
+ exit;
+ end;
+ end;
+ 't','T','F','f':
+ begin
+ if UpperCase(Str)='TRUE' then
+ begin
+ Result:=CONST_TRUE;
+ exit;
+ end
+ else if UpperCase(Str)='FALSE' then
+ begin
+ Result:=CONST_FALSE;
+ exit;
+ end;
+ end;
+ end;
+ end;
+ Result:=_String.create(Str);
+end;
+
+function mLeftPos(const SrcStr: AnsiString; SubChar: Char; sPos: Integer): Integer;
+var
+ i: Integer;
+begin
+ for i := sPos to Length(SrcStr) do
+ if SrcStr[i] = SubChar then begin
+ Result := i; Exit;
+ end;
+ Result := -1;
+end;
+
+function mRightPos(const SrcStr: AnsiString; SubChar: Char; sPos: Integer): Integer;
+var
+ i: Integer;
+begin
+ for i := sPos downto 1 do
+ if SrcStr[i] = SubChar then begin
+ Result := i; Exit;
+ end;
+ Result := -1;
+end;
+
+function mMidStr(const SrcStr: AnsiString; sPos, sCount: Integer): AnsiString;
+begin
+ Result := Copy(SrcStr, sPos, sCount);
+end;
+
+function JsonGetAttribute(const JSON, Name: string): string;
+var
+ i, j: Integer;
+begin
+ i := Pos('"'+Name+'":"', JSON);
+ if i > 0 then begin
+ i := i + Length(Name) + 4;
+ j := mLeftPos(JSON, '"', i);
+ Result := Copy(JSON, i, j - i);
+ end;
+end;
+
+function JsonGetAttributeAsInt(const JSON, Name: string): Integer;
+var
+ i, j: Integer;
+begin
+ Result := 0;
+ i := Pos('"'+Name+'":', JSON);
+ if i > 0 then begin
+ i := i + Length(Name) + 3;
+ j := mLeftPos(JSON, ',', i);
+ if (j < 0) then
+ j := mLeftPos(JSON, '}', i);
+ if (j > 0) then begin
+ if JSON[i] = '"' then i := i + 1;
+ if JSON[j-1] = '"' then j := j - 1;
+ Result := StrToIntDef(Copy(JSON, i, j - i), 0);
+ end;
+ end;
+end;
+
+function JsonGetAttributeAsDouble(const JSON, Name: string): double;
+var
+ i, j: Integer;
+begin
+ Result := 0;
+ i := Pos('"'+Name+'":', JSON);
+ if i > 0 then begin
+ i := i + Length(Name) + 3;
+ j := mLeftPos(JSON, ',', i);
+ if (j < 0) then
+ j := mLeftPos(JSON, '}', i);
+ if (j > 0) then begin
+ if JSON[i] = '"' then i := i + 1;
+ if JSON[j-1] = '"' then j := j - 1;
+ Result := StrToFloatDef(Copy(JSON, i, j - i), 0);
+ end;
+ end;
+end;
+
+{ JSONTokener }
+
+(**
+ * Construct a JSONTokener from a string.
+ *
+ * @param s A source string.
+ *)
+constructor JSONTokener.create(const s: string);
+begin
+ myIndex:=1;
+ mySource:=s;
+ Len1:=Length(mySource)+1;
+end;
+
+(**
+ * Back up one character. This provides a sort of lookahead capability,
+ * so that you can test for a digit or letter before attempting to parse
+ * the next number or identifier.
+*)
+procedure JSONTokener.back;
+begin
+ if myIndex>1 then Dec(myIndex);
+end;
+
+(**
+ * Get the hex value of a character (base16).
+ * @param c A character between '0' and '9' or between 'A' and 'F' or
+ * between 'a' and 'f'.
+ * @return An int between 0 and 15, or -1 if c was not a hex digit.
+ *)
+class function JSONTokener.dehexchar(c: char): integer;
+begin
+ if ((c >= '0') and (c <= '9')) then begin
+ Result:= (ord(c) - ord('0'));
+ exit;
+ end;
+ if ((c >= 'A') and (c <= 'F')) then begin
+ Result:= (ord(c) + 10 - ord('A'));
+ exit;
+ end;
+ if ((c >= 'a') and (c <= 'f')) then begin
+ Result:=ord(c) + 10 - ord('a');
+ exit;
+ end;
+ Result:=-1;
+end;
+
+
+(**
+ * Determine if the source string still contains characters that next()
+ * can consume.
+ * @return true if not yet at the end of the source.
+*)
+function JSONTokener.more: boolean;
+begin
+ Result:=myIndex<=Len1{System.length(mySource)+1};
+end;
+
+function JSONTokener.next: char;
+begin
+ if {$IFDEF BACK_OPT}myIndex<=Len1{$ELSE}more(){$ENDIF} then
+ begin
+ Result:=mySource[myIndex];
+ Inc(myIndex);
+ end
+ else
+ Result:=chr(0);
+end;
+
+
+ (**
+ * Consume the next character, and check that it matches a specified
+ * character.
+ * @param c The character to match.
+ * @return The character.
+ * @throws ParseException if the character does not match.
+ *)
+function JSONTokener.next(c: char): char;
+begin
+ Result:=next();
+ if (Result <> c) then
+ raise syntaxError('Expected ' + c + ' and instead saw ' + Result + '.');
+end;
+
+
+(**
+ * Get the next n characters.
+ *
+ * @param n The number of characters to take.
+ * @return A string of n characters.
+ * @exception ParseException
+ * Substring bounds error if there are not
+ * n characters remaining in the source string.
+ *)
+function JSONTokener.next(n: integer): string;
+var
+ i,j: integer;
+begin
+ i:=self.myIndex;
+ j:=i + n;
+ if (j > System.length(self.mySource)) then begin
+ raise syntaxError('Substring bounds error');
+ end;
+ self.myIndex:=self.myIndex + n;
+ Result:=copy (self.mySource,i,n); //substring(i, j)
+end;
+
+ (**
+ * Get the next char in the string, skipping whitespace
+ * and comments (slashslash, slashstar, and hash).
+ * @throws ParseException
+ * @return A character, or 0 if there are no more characters.
+ *)
+function JSONTokener.nextClean: char;
+var
+ c: char;
+begin
+ while true do
+ begin
+ {$IFDEF NEXT_OPT2}
+ if myIndex<=Len1 then
+ begin
+ Result:=mySource[myIndex];
+ Inc(myIndex);
+ end
+ else begin
+ Result:=#0;
+ exit;
+ end;
+ {$ELSE}
+ Result:=next();
+ {$ENDIF}
+ if (Result = '/') then
+ begin
+ case (next()) of
+ '/': begin
+ repeat
+ c:=next();
+ until (not ((c <> #10) and (c <> #13) and (c <> #0)));
+ end ;
+ '*':
+ begin
+ while (true) do
+ begin
+ c:=next();
+ if (c = #0) then
+ begin
+ raise syntaxError('Unclosed comment.');
+ end;
+ if (c = '*') then
+ begin
+ if (next() = '/') then break;
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ end;
+ end;
+ end
+ else begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:='/';
+ exit;
+ end;
+ end;
+ end
+ else if (Result = '#') then
+ begin
+ repeat
+ c:=next();
+ until (not ((c <> #10) and (c <> #13) and (c <> #0)));
+ end
+ else if ((Result = #0) or (Result > ' ')) then
+ exit;
+ end; //while
+end;
+
+
+(**
+ * Return the characters up to the next close quote character.
+ * Backslash processing is done. The formal JSON format does not
+ * allow strings in single quotes, but an implementation is allowed to
+ * accept them.
+ * @param quote The quoting character, either
+ * " (double quote) or
+ * ' (single quote).
+ * @return A String.
+ * @exception ParseException Unterminated string.
+ *)
+function JSONTokener.nextString (quote: char): string;
+var
+ c: char;
+ sb: string;
+ WCh:WideChar;
+begin
+ sb:='';
+ while (true) do
+ begin
+ c:=next();
+ case (c) of
+ #0, #10, #13:
+ begin
+ //Ignore #10 and #13 inside a string. By creation_zy 2009-11-22
+ if c=#0 then
+ raise syntaxError('Unterminated string')
+ else
+ continue;
+ end;
+ '\':
+ begin
+ c:=next();
+ case (c) of
+ {'b': // ?o backspace = #8
+ sb.append('\b');
+ break;}
+ 'b': //By creation_zy 2009-08-20
+ sb:=sb + #8;
+ 't':
+ sb:=sb + #9;
+ 'n':
+ sb:=sb + #10;
+ 'f':
+ sb:=sb + #12;
+ 'r':
+ sb:=sb + #13;
+ {case 'u':
+ sb.append((char)Integer.parseInt(next(4), 16));
+ break;
+ case 'x': \cx The control character corresponding to x
+ sb.append((char) Integer.parseInt(next(2), 16));
+ break;}
+ 'u': //By creation_zy 2009-08-20
+ begin
+ PWord(@WCh)^:=Word(HexToInt(next(4)));
+ sb:=sb+WCh;
+ end;
+ else
+ sb:=sb + c
+ end;
+ end
+ else begin
+ if (c = quote) then
+ begin
+ Result:=sb;
+ exit;
+ end;
+ sb:=sb + c
+ end;
+ end;
+ end;
+end;
+
+(**
+ * Get the text up but not including the specified character or the
+ * end of line, whichever comes first.
+ * @param d A delimiter character.
+ * @return A string.
+ *)
+function JSONTokener.nextTo(d: char): string;
+var
+ sb: string;
+ c: char;
+begin
+ //c:=#0;
+ sb:='';
+ while (true) do
+ begin
+ c:=next();
+ if ((c = d) or (c = #0) or (c = #10) or (c = #13)) then
+ begin
+ if (c <> #0) then
+ begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ end;
+ Result:=trim (sb);
+ exit;
+ end;
+ sb:=sb + c;
+ end;
+end;
+
+(**
+ * Get the text up but not including one of the specified delimeter
+ * characters or the end of line, whichever comes first.
+ * @param delimiters A set of delimiter characters.
+ * @return A string, trimmed.
+*)
+function JSONTokener.nextTo(const delimiters: string): char;
+var
+ c: char;
+ sb: string;
+begin
+ //c:=#0;
+ Result:=#0; //By creation_zy
+ sb:='';
+ while (true) do
+ begin
+ c:=next();
+ if ((pos (c,delimiters) > 0) or (c = #0) or
+ (c = #10) or (c = #13)) then
+ begin
+ if (c <> #0) then
+ begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ end;
+ sb:=trim(sb);
+ if (System.length(sb) > 0) then
+ Result:=sb[1];
+ exit;
+ end;
+ sb:=sb + c;
+ end;
+end;
+
+(**
+ * Get the next value. The value can be a Boolean, Double, Integer,
+ * JSONArray, JSONObject, or String, or the JSONObject.NULL object.
+ * @exception ParseException The source does not conform to JSON syntax.
+ *
+ * @return An object.
+*)
+function JSONTokener.nextValue(parent: JSONBase): TZAbstractObject; // by yangyxd parent
+var
+ c, b: char;
+ s , sb: string;
+ n:Integer;
+begin
+ c:=nextClean();
+
+ case (c) of
+ '"', #39: begin
+ Result:=_String.create (nextString(c));
+ exit;
+ end;
+ '{': begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:=JSONObject.create(self);
+ JSONObject(Result).Parent := parent;
+ exit;
+ end;
+ '[': begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:=JSONArray.create(self);
+ JSONArray(Result).Parent := parent;
+ exit;
+ end;
+ end;
+
+ (*
+ * Handle unquoted text. This could be the values true, false, or
+ * null, or it can be a number. An implementation (such as this one)
+ * is allowed to also accept non-standard forms.
+ *
+ * Accumulate characters until we reach the end of the text or a
+ * formatting character.
+ *)
+
+ sb:='';
+ b:=c;
+ while ((ord(c) >= ord(' ')) and (pos (c,',:]}/\\\"[{;=#') = 0)) do begin
+ sb:=sb + c;
+ c:=next();
+ end;
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+
+ (*
+ * If it is true, false, or null, return the proper value.
+ *)
+
+ s:=trim (sb);
+ n:=System.Length(s);
+ if n=0 then
+ raise syntaxError('Missing value.');
+ if n in [4,5] then //2009-09-14 Length limit before AnsiLowerCase. By creation_zy
+ begin
+ sb:=AnsiLowerCase(s);
+ if (sb = 'true') then
+ begin
+ Result:= _Boolean._TRUE;
+ exit;
+ end;
+
+ if (sb = 'false') then
+ begin
+ Result:=_Boolean._FALSE;
+ exit;
+ end;
+ if (sb = 'null') then
+ begin
+ Result:=JSONObject.NULL;
+ exit;
+ end;
+ end;
+
+ (*
+ * If it might be a number, try converting it. We support the 0- and 0x-
+ * conventions. If a number cannot be produced, then the value will just
+ * be a string. Note that the 0-, 0x-, plus, and implied string
+ * conventions are non-standard. A JSON parser is free to accept
+ * non-JSON forms as long as it accepts all correct JSON forms.
+ *)
+
+ if ( ((b >= '0') and (b <= '9')) or (b = '.')
+ or (b = '-') or (b = '+')) then
+ begin
+ if (b = '0') then begin
+ if ( (System.length(s) > 2) and
+ ((s[2] = 'x') or (s[2] = 'X') ) ) then
+ begin
+ try
+ Result:=_Integer.create(_Integer.parseInt(copy(s,3,System.length(s)),16));
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+ end else begin
+ try
+ if (System.length(s) >= 2) and (s[2]='.') then //2009-09-14 By creation_zy
+ Result:=_Double.create(s)
+ else
+ Result:=_Integer.create(_Integer.parseInt(s,8));
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+ end;
+ end;
+ if Pos('.',s)=0 then //2011-10-02 Bug fixed. By creation_zy
+ try
+ Result:=_Integer.create(s);
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+
+ try
+ Result:=_Double.create(s);
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+ end;
+ Result:=_String.create(s);
+end;
+
+(**
+ * Skip characters until the next character is the requested character.
+ * If the requested character is not found, no characters are skipped.
+ * @param to A character to skip to.
+ * @return The requested character, or zero if the requested character
+ * is not found.
+ *)
+function JSONTokener.skipTo(_to: char): char;
+var
+ c: char;
+ index: integer;
+begin
+ index:=self.myIndex;
+ repeat
+ c:=next();
+ if (c = #0) then
+ begin
+ self.myIndex:=index;
+ Result:=c;
+ exit;
+ end;
+ until c=_to;
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:=c;
+ exit;
+end;
+
+(**
+ * Skip characters until past the requested string.
+ * If it is not found, we are left at the end of the source.
+ * @param to A string to skip past.
+ *)
+procedure JSONTokener.skipPast(const _to: string);
+begin
+ self.myIndex:=pos (_to, copy(mySource, self.myIndex, System.length(mySource)));
+ if (self.myIndex < 0) then begin
+ self.myIndex:=System.length(self.mySource)+1;
+ end else begin
+ self.myIndex:=self.myIndex + System.length(_to);
+ end;
+end;
+
+
+
+(**
+ * Make a ParseException to signal a syntax error.
+ *
+ * @param message The error message.
+ * @return A ParseException object, suitable for throwing
+ *)
+function JSONTokener.syntaxError(const _message: string): ParseException;
+begin
+ Result:=ParseException.create (_message + toString()+' postion: ' //' prximo a: '
+ + copy (toString(),self.myIndex,10), self.myIndex);
+end;
+
+(**
+ * Make a printable string of this JSONTokener.
+ *
+ * @return " at character [this.myIndex] of [this.mySource]"
+ *)
+
+
+function JSONTokener.toString: string;
+begin
+ Result:=' at character ' + intToStr(myIndex) + ' of ' + mySource;
+end;
+
+
+(**
+ * Convert %hh sequences to single characters, and
+ * convert plus to space.
+ * @param s A string that may contain
+ * + (plus) and
+ * %hh sequences.
+ * @return The unescaped string.
+ *)
+function JSONTokener.unescape(const s: string): string;
+var
+ len, i,d,e: integer;
+ b: string;
+ c: char;
+begin
+ len:=System.length(s);
+ b:='';
+ i:=1;
+ while ( i <= len ) do begin
+ c:=s[i];
+ if (c = '+') then begin
+ c:=' ';
+ end
+ else if ((c = '%') and ((i + 2) <= len)) then
+ begin
+ d:=dehexchar(s[i + 1]);
+ e:=dehexchar(s[i + 2]);
+ if ((d >= 0) and (e >= 0)) then
+ begin
+ c:=chr(d * 16 + e);
+ i:=i + 2;
+ end;
+ end;
+ b:=b + c;
+ i:=i + 1;
+ end;
+ Result:=b ;
+end;
+
+{ JSONObject }
+
+(**
+* Construct an empty JSONObject.
+*)
+constructor JSONObject.create;
+begin
+ myHashMap:=TStringList.create;
+ inherited Create;
+end;
+
+
+(**
+ * Construct a JSONObject from a subset of another JSONObject.
+ * An array of strings is used to identify the keys that should be copied.
+ * Missing keys are ignored.
+ * @param jo A JSONObject.
+ * @param sa An array of strings.
+ *)
+constructor JSONObject.create(jo: JSONObject; sa: array of string);
+var
+ i: integer;
+begin
+ create();
+ for i:=low(sa) to high(sa) do
+ putOpt(sa[i], jo.opt(sa[i]).Clone);
+end;
+
+(**
+ * Construct a JSONObject from a JSONTokener.
+ * @param x A JSONTokener object containing the source string.
+ * @throws ParseException if there is a syntax error in the source string.
+ *)
+constructor JSONObject.create(x: JSONTokener);
+begin
+ create ;
+ UpdateByTokener(x);
+end;
+
+(**
+ * Construct a JSONObject from a Map.
+ * @param map A map object that can be used to initialize the contents of
+ * the JSONObject.
+ *)
+constructor JSONObject.create(map: TStringList);
+var
+ i: integer;
+begin
+ myHashMap:=TStringlist.create;
+ for i:=0 to map.Count -1 do
+ myHashMap.AddObject(map[i],map.Objects[i]);
+end;
+
+(**
+ * Construct a JSONObject from a string.
+ * This is the most commonly used JSONObject constructor.
+ * @param string A string beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ * @exception ParseException The string must be properly formatted.
+ *)
+constructor JSONObject.create(const s: string);
+var
+ token: JSOnTokener;
+begin
+ if s='' then //Add by creation_zy 2008-10-21
+ begin
+ create();
+ exit;
+ end;
+ token:=JSONTokener.create(s);
+ try
+ create(token);
+ finally
+ token.free;
+ end;
+end;
+
+
+constructor JSONObject.CreateInArray(Ay: JSONArray);
+begin
+ create;
+ if Ay<>nil then
+ Ay.put(Self);
+end;
+
+(**
+ * Accumulate values under a key. It is similar to the put method except
+ * that if there is already an object stored under the key then a
+ * JSONArray is stored under the key to hold all of the accumulated values.
+ * If there is already a JSONArray, then the new value is appended to it.
+ * In contrast, the put method replaces the previous value.
+ * @param key A key string.
+ * @param value An object to be accumulated under the key.
+ * @return this.
+ * @throws NullPointerException if the key is null
+ *)
+function JSONObject.accumulate(const key: string; value: TZAbstractObject): JSONObject;
+var
+ a: JSONArray;
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o = nil) then
+ put(key, value)
+ else if (o is JSONArray) then
+ begin
+ a:=JSONArray(o);
+ a.put(value);
+ end
+ else begin
+ a:=JSONArray.create;
+ a.put(o.Clone);
+ a.put(value);
+ put(key, a);
+ end;
+ Result:=self;
+end;
+
+
+(**
+ * Get the value object associated with a key.
+ *
+ * @param key A key string.
+ * @return The object associated with the key.
+ * @exception NoSuchElementException if the key is not found.
+ *)
+function JSONObject.get(const key: string): TZAbstractObject;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o = nil) then
+ raise NoSuchElementException.create('JSONObject['+quote(key)+'] not found.');
+ Result:=o;
+end;
+
+
+(**
+ * Get the boolean value associated with a key.
+ *
+ * @param key A key string.
+ * @return The truth.
+ * @exception NoSuchElementException if the key is not found.
+ * @exception ClassCastException
+ * if the value is not a Boolean or the String "true" or "false".
+ *)
+function JSONObject.getBoolean(const key: string): boolean;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o.equals(_Boolean._FALSE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('false'))) then begin
+ Result:=false;
+ exit;
+ end
+ else if (o.equals(_Boolean._TRUE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('true'))) then begin
+ Result:=true;
+ exit;
+ end;
+ raise ClassCastException.create('JSONObject[' +
+ quote(key) + '] is not a Boolean.');
+end;
+
+function JSONObject.getDouble(const key: string): double;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is _Number) then
+ begin
+ Result:=_Number (o).doubleValue();
+ exit;
+ end ;
+ if (o is _String) then
+ begin
+ Result:=StrToFloat (_String(o).toString(), getFormatSettings());
+ exit;
+ end;
+ raise NumberFormatException.create('JSONObject['+quote(key)+'] is not a number.');
+end;
+
+
+(**
+ * Get the int value associated with a key.
+ *
+ * @param key A key string.
+ * @return The integer value.
+ * @exception NoSuchElementException if the key is not found
+ * @exception NumberFormatException
+ * if the value cannot be converted to a number.
+ *)
+function JSONObject.getInt(const key: string): integer;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is _Number) then
+ Result:= _Number(o).intValue()
+ else
+ Result:= Round(getDouble(key));
+end;
+
+
+function JSONObject.GetInt64(const key: string): Int64;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is _Number) then
+ Result:= _Number(o).int64Value()
+ else
+ Result:= Round(getDouble(key));
+end;
+
+(**
+ * Get the JSONArray value associated with a key.
+ *
+ * @param key A key string.
+ * @return A JSONArray which is the value.
+ * @exception NoSuchElementException if the key is not found or
+ * if the value is not a JSONArray.
+ *)
+function JSONObject.getJSONArray(const key: string): JSONArray;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is JSONArray) then
+ Result:=JSONArray(o)
+ else
+ raise NoSuchElementException.create('JSONObject[' +
+ quote(key) + '] is not a JSONArray.');
+end;
+
+
+(**
+ * Get the JSONObject value associated with a key.
+ *
+ * @param key A key string.
+ * @return A JSONObject which is the value.
+ * @exception NoSuchElementException if the key is not found or
+ * if the value is not a JSONObject.
+ *)
+function JSONObject.getJSONObject(const key: string): JSONObject;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is JSONObject) then
+ Result:=JSONObject(o)
+ else
+ raise NoSuchElementException.create('JSONObject[' +
+ quote(key) + '] is not a JSONObject.');
+end;
+
+
+(**
+ * Get the string associated with a key.
+ *
+ * @param key A key string.
+ * @return A string which is the value.
+ * @exception NoSuchElementException if the key is not found.
+*)
+function JSONObject.getString(const key: string): string;
+begin
+ Result:=get(key).toString();
+end;
+
+
+(**
+ * Determine if the JSONObject contains a specific key.
+ * @param key A key string.
+ * @return true if the key exists in the JSONObject.
+ *)
+function JSONObject.has(const key: string): boolean;
+begin
+ Result:=myHashMap.IndexOf(key)>=0;
+end;
+
+function JSONObject.IndexOfObject(aobj: TObject): Integer;
+var
+ i: Integer;
+begin
+ for i := 0 to myHashMap.Count - 1 do
+ if myHashMap.Objects[i] = aobj then begin
+ Result := I;
+ Exit;
+ end;
+ Result := -1;
+end;
+
+(**
+ * Determine if the value associated with the key is null or if there is
+ * no value.
+ * @param key A key string.
+ * @return true if there is no value associated with the key or if
+ * the value is the JSONObject.NULL object.
+ *)
+function JSONObject.isNull(const key: string): boolean;
+begin
+ Result:=NULL.equals(opt(key));
+end;
+
+function JSONObject.keys: TStringList;
+var
+ i: integer;
+begin
+ Result:=TStringList.Create;
+ for i:=0 to myHashMap.Count -1 do
+ Result.add (myHashMap[i]);
+end;
+
+function JSONObject.length: integer;
+begin
+ Result:=myHashMap.Count;
+end;
+
+
+(**
+ * Produce a JSONArray containing the names of the elements of this
+ * JSONObject.
+ * @return A JSONArray containing the key strings, or null if the JSONObject
+ * is empty.
+ *)
+function JSONObject.names: JSONArray;
+var
+ i,c: integer;
+ k: TStringList;
+begin
+ Result:=nil;
+ k:=keys;
+ try
+ c:=k.Count;
+ if c>0 then //2013-05-04 Fix memory leak bug found by K.o.s
+ begin
+ Result:=JSONArray.create;
+ for i:=0 to c-1 do
+ Result.put(_String.create(k[i]));
+ end;
+ finally
+ k.free;
+ end;
+end;
+
+function JSONObject.NextSibling: JSONObject;
+var
+ i: Integer;
+begin
+ if not Assigned(Parent) then
+ Result := nil
+ else begin
+ i := Parent.IndexOfObject(Self) + 1;
+ if (i > 0) and (i < Parent.Count) then begin
+ if Parent.Child[i] is JSONObject then
+ Result := JSONObject(Parent.Child[i])
+ else Result := nil;
+ end else
+ Result := nil;
+ end;
+end;
+
+class function JSONObject.numberToString(n: _Number): string;
+begin
+ if (n = nil) then
+ Result:=''
+ else if (n is _Integer) then
+ Result:=IntToStr(n.intValue)
+ else
+ Result:=FloatToStr(n.doubleValue, getFormatSettings());
+end;
+
+
+(**
+ * Get an optional value associated with a key.
+ * @param key A key string.
+ * @return An object which is the value, or null if there is no value.
+ * @exception NullPointerException The key must not be null.
+ *)
+function JSONObject.opt(const key: string): TZAbstractObject;
+var
+ i:Integer;
+begin
+ i:=myHashMap.IndexOf(key);
+ if i<0 then
+ Result:=nil
+ else
+ Result:=TZAbstractObject(myHashMap.Objects[i]);
+end;
+
+function JSONObject.Opt2(key, key2: string): TZAbstractObject;
+var
+ i:Integer;
+begin
+ i:=myHashMap.IndexOf(key);
+ if i<0 then
+ i:=myHashMap.IndexOf(key2);
+ if i<0 then
+ Result:=nil
+ else
+ Result:=TZAbstractObject(myHashMap.Objects[i]);
+end;
+
+(**
+ * Get an optional boolean associated with a key.
+ * It returns false if there is no such key, or if the value is not
+ * Boolean.TRUE or the String "true".
+ *
+ * @param key A key string.
+ * @return The truth.
+ *)
+function JSONObject.optBoolean(const key: string): boolean;
+begin
+ Result:=optBoolean(key, false);
+end;
+
+
+(**
+ * Get an optional boolean associated with a key.
+ * It returns the defaultValue if there is no such key, or if it is not
+ * a Boolean or the String "true" or "false" (case insensitive).
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return The truth.
+ *)
+function JSONObject.optBoolean(const key: string;
+ defaultValue: boolean): boolean;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> nil) then
+ begin
+ if o.ClassType=_Boolean then //2009-03-06 By creation_zy
+ begin
+ Result:=_Boolean(o).fvalue;
+ exit;
+ end
+ else if //o.equals(_Boolean._FALSE) or
+ ((o is _String) and
+ (_String(o).equalsIgnoreCase('false'))) then begin
+ Result:=false;
+ exit;
+ end
+ else if //o.equals(_Boolean._TRUE) or
+ ((o is _String) and
+ (_String(o).equalsIgnoreCase('true'))) then begin
+ Result:=true;
+ exit;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+
+(**
+ * Get an optional double associated with a key,
+ * or NaN if there is no such key or if its value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A string which is the key.
+ * @return An object which is the value.
+ *)
+function JSONObject.optDouble(const key: string): double;
+begin
+ Result:=optDouble(key, _Double.NaN);
+end;
+
+
+(**
+ * Get an optional double associated with a key, or the
+ * defaultValue if there is no such key or if its value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return An object which is the value.
+ *)
+function JSONObject.optDouble(const key: string; defaultValue: double): double;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> nil) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).doubleValue();
+ exit;
+ end;
+ try
+ Result:=_Double.create(_String(o)).doubleValue();
+ exit;
+ except
+ on e:Exception do
+ begin
+ Result:=defaultValue;
+ exit;
+ end;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+(**
+ * Get an optional int value associated with a key,
+ * or zero if there is no such key or if the value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A key string.
+ * @return An object which is the value.
+ *)
+function JSONObject.optInt(const key: string): integer;
+begin
+ Result:=optInt(key, 0);
+end;
+
+
+(**
+ * Get an optional int value associated with a key,
+ * or the default if there is no such key or if the value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return An object which is the value.
+ *)
+function JSONObject.optInt(const key: string; defaultValue: integer): integer;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> null) and ( o <> nil ) then //By creation_zy. Add compare to nil
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).intValue();
+ exit;
+ end;
+ try
+ Result:=_Integer.parseInt(_String(o));
+ except
+ on e:Exception do
+ begin
+ Result:=defaultValue;
+ end;
+ end;
+ end
+ else //By creation_zy
+ Result:=defaultValue;
+end;
+
+function JSONObject.OptInt2(key, key2: String; DefaultValue: Integer): Integer;
+var
+ o:TZAbstractObject;
+begin
+ o:=Opt2(key,key2);
+ if o<>nil then
+ Result:=TZAbstractObject.getInt(o,DefaultValue)
+ else
+ Result:=DefaultValue;
+end;
+
+function JSONObject.OptInt64(const key: string): int64;
+begin
+ Result:=optInt64(key, 0);
+end;
+
+function JSONObject.OptInt64(const key: string; defaultValue: int64): int64;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> null) and ( o <> nil ) then //By creation_zy. Add compare to nil
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).int64Value();
+ exit;
+ end;
+ try
+ Result:=_Integer.parseInt64(_String(o));
+ except
+ on e:Exception do
+ begin
+ Result:=defaultValue;
+ end;
+ end;
+ end
+ else //By creation_zy
+ Result:=defaultValue;
+end;
+
+(**
+ * Get an optional JSONArray associated with a key.
+ * It returns null if there is no such key, or if its value is not a
+ * JSONArray.
+ *
+ * @param key A key string.
+ * @return A JSONArray which is the value.
+ *)
+function JSONObject.optJSONArray(const key: string): JSONArray;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is JSONArray) then
+ Result:=JSONArray(o)
+ else
+ Result:=nil;
+end;
+
+
+(**
+ * Get an optional JSONObject associated with a key.
+ * It returns null if there is no such key, or if its value is not a
+ * JSONObject.
+ *
+ * @param key A key string.
+ * @return A JSONObject which is the value.
+ *)
+function JSONObject.optJSONObject(const key: string): JSONObject;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is JSONObject) then
+ Result:=JSONObject(o)
+ else
+ Result:=nil;
+end;
+
+{$IFDEF J_OBJECT}
+function JSONObject.OptObject(const key: string;
+ defaultValue: TObject): TObject;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is _Object) then
+ Result:=_Object(o).AsObject
+ else
+ Result:=defaultValue;
+end;
+
+function JSONObject.OptObject(const key: string): TObject;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is _Object) then
+ Result:=_Object(o).AsObject
+ else
+ Result:=nil;
+end;
+{$ENDIF}
+
+(**
+ * Get an optional string associated with a key.
+ * It returns an empty string if there is no such key. If the value is not
+ * a string and is not null, then it is coverted to a string.
+ *
+ * @param key A key string.
+ * @return A string which is the value.
+ *)
+function JSONObject.optString(const key: string): string;
+var
+ o: TZAbstractObject ;
+ i:Integer;
+begin
+ i:=myHashMap.IndexOf(key);
+ if i<0 then
+ Result:=''
+ else begin
+ o:=TZAbstractObject(myHashMap.Objects[i]);
+ if (o <> nil) then
+ Result:=o.toString()
+ else
+ Result:='';
+ end;
+end;
+
+(**
+ * Get an optional string associated with a key.
+ * It returns the defaultValue if there is no such key.
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return A string which is the value.
+ *)
+function JSONObject.optString(const key, defaultValue: string): string;
+var
+ o: TZAbstractObject ;
+begin
+ o:=Opt(key);
+ if (o <> nil) then
+ Result:=o.toString()
+ else
+ Result:=defaultValue;
+end;
+
+function JSONObject.OptString2(key, key2: String; DefaultValue: String): String;
+var
+ o:TZAbstractObject;
+begin
+ o:=Opt2(key,key2);
+ if o<>nil then
+ Result:=o.toString()
+ else
+ Result:=DefaultValue;
+end;
+
+(**
+ * Put a key/boolean pair in the JSONObject.
+ *
+ * @param key A key string.
+ * @param value A boolean which is the value.
+ * @return this.
+ *)
+function JSONObject.put(const key: string; value: boolean): JSONObject;
+begin
+ put(key, _Boolean.valueOf(value));
+ Result:=self;
+end;
+
+(**
+ * Put a key/double pair in the JSONObject.
+ *
+ * @param key A key string.
+ * @param value A double which is the value.
+ * @return this.
+ *)
+function JSONObject.put(const key: string; value: double): JSONObject;
+begin
+ put(key, _Double.create(value));
+ Result:=self;
+end;
+
+
+(**
+ * Put a key/int pair in the JSONObject.
+ *
+ * @param key A key string.
+ * @param value An int which is the value.
+ * @return this.
+ *)
+function JSONObject.put(const key: string; value: integer): JSONObject;
+begin
+ put(key, _Integer.create(value));
+ Result:=self;
+end;
+
+
+(**
+ * Put a key/value pair in the JSONObject. If the value is null,
+ * then the key will be removed from the JSONObject if it is present.
+ * @param key A key string.
+ * @param value An object which is the value. It should be of one of these
+ * types: Boolean, Double, Integer, JSONArray, JSONObject, String, or the
+ * JSONObject.NULL object.
+ * @return this.
+ * @exception NullPointerException The key must be non-null.
+ *)
+function JSONObject.put(const key: string; value: TZAbstractObject): JSONObject;
+var
+ temp: TObject;
+ i: integer;
+begin
+ if (key = '') then
+ begin
+ raise NullPointerException.create('Null key.');
+ end ;
+ if (value <> nil) then {$D+}
+ begin
+ i:=myHashMap.IndexOf(key);
+ if ( i >= 0) then
+ begin
+ temp:=myHashMap.Objects [i];
+ myHashMap.Objects[i]:=value;
+ if (temp<>CNULL) and (temp<>CONST_FALSE) and (temp<>CONST_TRUE) then //Prevent to free const obj. By craetion_zy 2009-11-21
+ temp.free;
+ end
+ else
+ myHashMap.AddObject(key, value);
+ end
+ else begin
+ temp:=remove(key);
+ if (temp<>nil) and (temp<>CNULL) and (temp<>CONST_FALSE) and (temp<>CONST_TRUE) then //Prevent to free const obj. By craetion_zy 2009-11-21
+ temp.free;
+ end;
+ Result:=self;
+end;
+
+function JSONObject.put(const key, value: string): JSONObject;
+begin
+ put(key, _String.create(value));
+ Result:=self;
+end;
+
+{$IFDEF J_OBJECT}
+function JSONObject.Put(const key: string; value: TObject): JSONObject;
+begin
+ put(key, _Object.create(value));
+ Result:=self;
+end;
+function JSONObject.Put(const key: string; value: int64): JSONObject;
+begin
+ put(key, _Integer.create(value));
+ Result:=self;
+end;
+
+{$ENDIF}
+
+(**
+ * Put a key/value pair in the JSONObject, but only if the
+ * value is non-null.
+ * @param key A key string.
+ * @param value An object which is the value. It should be of one of these
+ * types: Boolean, Double, Integer, JSONArray, JSONObject, String, or the
+ * JSONObject.NULL object.
+ * @return this.
+ * @exception NullPointerException The key must be non-null.
+ *)
+function JSONObject.putOpt(const key: string; value: TZAbstractObject): JSONObject;
+begin
+ if (value <> nil) then
+ put(key, value);
+ Result:=self;
+end;
+
+
+(**
+ * Produce a string in double quotes with backslash sequences in all the
+ * right places.
+ * @param string A String
+ * @return A String correctly formatted for insertion in a JSON message.
+ *)
+class function JSONObject.quote(const s: string): string;
+var
+ b,c: char;
+ i, len: integer;
+ sb, t: string;
+begin
+ if ((s = '') or (System.Length(s) = 0)) then
+ begin
+ Result:= '""';
+ exit;
+ end;
+
+ //b:=#0;
+ c:=#0;
+ len:=System.length(s);
+ //SetLength (s, len+4);
+ t:='';
+
+ sb:=sb +'"';
+ i:=1;
+ while i<=len do
+ begin
+ b:=c;
+ c:=s[i];
+ case (c) of
+ '\', '"':
+ begin
+ sb:=sb + '\';
+ sb:=sb + c;
+ end;
+ '/':
+ begin
+ if (b = '<') then
+ begin
+ sb:=sb + '\';
+ end;
+ sb:=sb + c;
+ end;
+ {#8, #9, #10, #12, #13:
+ begin
+ sb:=sb + c;
+ end;}
+ //Output special character smaller than space. By creation_zy 2009-11-22
+ #0: sb:=sb + '\u0000';
+ #1..#7: sb:=sb + '\u000'+Char(Byte('0')+Byte(c));
+ #8: sb:=sb + '\b';
+ #9: sb:=sb + '\t';
+ #10: sb:=sb + '\n';
+ #12: sb:=sb + '\f';
+ #13: sb:=sb + '\r';
+ else
+ begin
+ if (c < ' ') then
+ begin
+ t:='000' + _Integer.toHexString(c);
+ sb:=sb + '\u' + copy (t,System.length(t)-3,4);
+ end
+ else if UnicodeOutput and (c>#128) and (i#128) and (i
+ * Warning: This method assumes that the data structure is acyclical.
+ *
+ * @return a printable, displayable, portable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+function JSONObject.toString: string;
+var
+ _keys: TStringList;
+ o, sb: string;
+ i :integer;
+begin
+ _keys:=keys();
+ try
+ sb:='{';
+
+ for i:=0 to _keys.count -1 do
+ begin
+ if (System.length(sb) > 1) then
+ begin
+ sb:= sb + ',';
+ end;
+ o:=_keys[i];
+ if SimpleJSON and IsSimpString(o) then //By creation_zy
+ sb:=sb + o
+ else
+ sb:=sb + quote(o);
+ sb:=sb + ':';
+ sb:= sb + valueToString(TZAbstractObject(myHashMap.Objects[myHashMap.IndexOf(o)]));
+ end;
+ sb:=sb + '}';
+ Result:=sb;
+ finally
+ _keys.free;
+ end;
+end;
+
+
+(**
+ * Make a prettyprinted JSON external form string of this JSONObject.
+ *
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param indentFactor The number of spaces to add to each level of
+ * indentation.
+ * @return a printable, displayable, portable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+procedure JSONObject.SaveToStream(stream: TStream);
+var
+ _keys: TStringList;
+ o: string;
+ i, j :integer;
+begin
+ _keys:=keys();
+ try
+ WriteChar(stream, '{');
+ j := 1;
+ for i:=0 to _keys.count -1 do
+ begin
+ if (j > 1) then
+ WriteChar(stream, ',');
+ o:=_keys[i];
+ if SimpleJSON and IsSimpString(o) then //By creation_zy
+ WriteString(stream, o)
+ else
+ quoteToStream(stream, o);
+ WriteChar(stream, ':');
+ ValueToStream(TZAbstractObject(myHashMap.Objects[myHashMap.IndexOf(o)]), stream);
+ Inc(j);
+ end;
+ WriteChar(stream, '}');
+ finally
+ _keys.free;
+ end;
+end;
+
+function JSONObject.toString2(indentFactor: integer): string;
+begin
+ Result:=toString3(indentFactor, 0);
+end;
+
+(**
+ * Make a prettyprinted JSON string of this JSONObject.
+ *
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param indentFactor The number of spaces to add to each level of
+ * indentation.
+ * @param indent The indentation of the top level.
+ * @return a printable, displayable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+function JSONObject.toString3(indentFactor, indent: integer): string;
+var
+ j , n , newindent: integer;
+ _keys: TStringList;
+ o, sb: string;
+begin
+ //i:=0;
+ n:=length();
+ if (n = 0) then begin
+ Result:='{}';
+ exit;
+ end;
+ _keys:=keys();
+ try
+ sb:=sb + '{';
+ newindent:=indent + indentFactor;
+ if (n = 1) then
+ begin
+ o:=_keys[0];
+ sb:= sb + quote(o);
+ sb:= sb + ': ';
+ sb:= sb + valueToString(TZAbstractObject(myHashMap
+ .Objects[myHashMap.IndexOf(o)])
+ , indentFactor, indent);
+ end
+ else begin
+ for j:=0 to _keys.count -1 do
+ begin
+ o:=_keys[j];
+ if (System.length(sb) > 1) then
+ begin
+ sb:=sb + ','+ #10;
+ end
+ else begin
+ sb:= sb + #10;
+ end;
+ sb:= sb + SpaceStr(newindent) + quote(o) + ': ';
+ sb:= sb + valueToString(TZAbstractObject(myHashMap.Objects[myHashMap.IndexOf(o)])
+ , indentFactor, newindent);
+ end;
+ if (System.length(sb) > 1) then
+ begin
+ sb:=sb + #10;
+ sb:= sb + SpaceStr(indent);
+ end;
+ end;
+ sb:= sb + '}';
+ Result:=sb;
+ finally
+ _keys.Free; //Memory leak fixed. By creation_zy 2009-08-03
+ end;
+end;
+
+class function JSONObject.NULL: _NULL;
+begin
+ Result:=CNULL;
+end;
+
+(**
+ * Make JSON string of an object value.
+ *
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param value The value to be serialized.
+ * @return a printable, displayable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+class function JSONObject.valueToString(value: TZAbstractObject): string;
+begin
+ if ((value = nil) or (value.equals(null))) then begin
+ Result:='null';
+ exit;
+ end;
+ if (value is _Number) then begin
+ Result:=numberToString(_Number(value));
+ exit;
+ end;
+ if ((value is _Boolean) or (value is JSONObject) or
+ (value is JSONArray)) then begin
+ Result:=value.toString();
+ exit;
+ end;
+ Result:=quote(value.toString());
+end;
+
+class procedure JSONObject.ValueToStream(value: TZAbstractObject;
+ stream: TStream);
+var
+ m: TStringStream;
+begin
+ if ((value = nil) or (value.equals(null))) then begin
+ WriteString(stream, 'null');
+ exit;
+ end;
+ if (value is _Number) then begin
+ WriteString(stream, numberToString(_Number(value)));
+ exit;
+ end;
+ if ((value is _Boolean) or (value is JSONObject) or
+ (value is JSONArray)) then begin
+ value.SaveToStream(stream);
+ exit;
+ end;
+ m := TStringStream.Create('');
+ try
+ value.SaveToStream(m);
+ quoteToStream(stream, m.DataString);
+ //WriteString(stream, quote(m.DataString));
+ finally
+ m.Free;
+ end;
+end;
+
+
+
+(**
+ * Make a prettyprinted JSON string of an object value.
+ *
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param value The value to be serialized.
+ * @param indentFactor The number of spaces to add to each level of
+ * indentation.
+ * @param indent The indentation of the top level.
+ * @return a printable, displayable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+class function JSONObject.valueToString(value: TZAbstractObject;
+ indentFactor, indent: integer): string;
+begin
+ if ((value = nil) or (value.equals(nil))) then begin
+ Result:='null';
+ exit;
+ end;
+ if (value is _Number) then begin
+ Result:=numberToString(_Number(value));
+ exit;
+ end;
+ if (value is _Boolean) then begin
+ Result:= value.toString();
+ exit;
+ end;
+ if (value is JSONObject) then begin
+ Result:=((JSONObject(value)).toString3(indentFactor, indent));
+ exit;
+ end;
+ if (value is JSONArray) then begin
+ Result:=((JSONArray(value)).toString3(indentFactor, indent));
+ exit;
+ end;
+ Result:=quote(value.toString());
+end;
+
+procedure JSONObject.clean;
+var
+ i: integer;
+ MyObj:TObject;
+begin
+ for i:=Pred(myHashMap.Count) downto 0 do
+ begin
+ MyObj:=myHashMap.Objects[i];
+ if (MyObj <> CONST_FALSE) and (MyObj <> CONST_TRUE) and (MyObj <> CNULL) then
+ MyObj.Free;
+ end;
+ myHashMap.Clear;
+end;
+
+
+(**
+* Assign the values to other json Object.
+* @param JSONObject objeto to assign Values
+*)
+procedure JSONObject.assignTo (json: JSONObject) ;
+var
+ _keys: TStringList;
+ i: integer;
+begin
+ _keys:=keys;
+ try
+ for i:=0 to _keys.Count -1 do
+ begin
+ json.put (_keys[i],get(_keys[i]).Clone);
+ end;
+ finally
+ _keys.free;
+ end;
+end;
+
+function JSONObject.Clone: TZAbstractObject;
+begin
+ Result:=JSONObject.create(self.toString());
+end;
+
+function JSONObject.GetPropValues(const Key: String): String;
+begin
+ Result:=OptString(Key);
+end;
+
+procedure JSONObject.SetPropValues(const Key: String; const Value: String);
+begin
+ Put(Key, Value);
+end;
+
+function JSONObject.GetCascadeValue(const Keys: array of String): String;
+var
+ i:Integer;
+ TmpProp:JSONObject;
+begin
+ Result:='';
+ TmpProp:=Self;
+ for i:=Low(Keys) to High(Keys) do
+ begin
+ if i=High(Keys) then
+ begin
+ Result:=TmpProp.PropValues[Keys[i]];
+ exit;
+ end;
+ TmpProp:=TmpProp.OptJSONObject(Keys[i]);
+ if TmpProp=nil then exit;
+ end;
+end;
+
+function JSONObject.GetChild(Index: Integer): TZAbstractObject;
+begin
+ Result := JSONObject(myHashMap.Objects[index]);
+end;
+
+function JSONObject.GetCount: Integer;
+begin
+ Result := myHashMap.Count;
+end;
+
+function JSONObject.GetCascadeValEx(const Keys: array of String): String;
+var
+ i:Integer;
+ TmpProp,p:JSONObject;
+begin
+ Result:='';
+ TmpProp:=Self;
+ for i:=Low(Keys) to High(Keys) do
+ begin
+ if i=High(Keys) then
+ begin
+ Result:=TmpProp.PropValues[Keys[i]];
+ exit;
+ end;
+ p:=TmpProp.OptJSONObject(Keys[i]);
+ if p=nil then
+ begin
+ Result:=TmpProp.OptString(Keys[i]);
+ exit;
+ end;
+ TmpProp:=p;
+ end;
+end;
+
+function JSONObject.GetCascadeValObj(
+ const Keys: array of String): TZAbstractObject;
+var
+ i:Integer;
+ TmpProp:JSONObject;
+begin
+ Result:=nil;
+ TmpProp:=Self;
+ for i:=Low(Keys) to High(Keys) do
+ begin
+ if i=High(Keys) then
+ begin
+ Result:=TmpProp.Opt(Keys[i]);
+ exit;
+ end;
+ TmpProp:=TmpProp.OptJSONObject(Keys[i]);
+ if TmpProp=nil then exit;
+ end;
+end;
+
+procedure JSONObject.SetAsString(const Value: String);
+var
+ token:JSOnTokener;
+begin
+ Clean;
+ if System.Length(Value)<=2 then exit;
+ token:=JSONTokener.create(Value);
+ try
+ UpdateByTokener(token);
+ finally
+ token.free;
+ end;
+end;
+
+function JSONObject.GetDiffFrom(Source: JSONObject; UseSrc: Boolean): JSONObject;
+var
+ sl:TStrings;
+ i:Integer;
+ mstr:String;
+ z,sz:TZAbstractObject;
+begin
+ Result:=JSONObject.Create;
+ if UseSrc then
+ sl:=Source.Keys
+ else
+ sl:=Keys;
+ with sl do
+ begin
+ for i:=0 to Pred(Count) do
+ begin
+ mstr:=Strings[i];
+ if UseSrc then
+ begin
+ z:=Self.Opt(mstr);
+ sz:=Source.ValObjByIndex[i];
+ if z=nil then
+ begin
+ Result.Put(mstr,sz.Clone);
+ continue;
+ end;
+ end
+ else begin
+ sz:=Source.Opt(mstr);
+ z:=Self.ValObjByIndex[i];
+ if sz=nil then
+ begin
+ Result.Put(mstr,z.Clone);
+ continue;
+ end;
+ end;
+ if sz.ClassType=z.ClassType then
+ begin
+ if sz.toString=z.toString then continue;
+ if sz.ClassType=JSONObject then
+ begin
+ Result.Put(mstr,JSONObject(z).GetDiffFrom(JSONObject(sz),UseSrc));
+ continue;
+ end;
+ end;
+ if UseSrc then
+ Result.Put(mstr,sz.Clone)
+ else if z<>nil then //Ӧ...
+ Result.Put(mstr,z.Clone);
+ end;
+ Free;
+ end;
+end;
+
+procedure JSONObject.Delete(index: Integer);
+begin
+ SafeFreeJObj(myHashMap.Objects[index]);
+ self.myHashMap.delete(index);
+end;
+
+procedure JSONObject.RemoveByKeyHeader(const Header: String);
+var
+ i:Integer;
+begin
+ with Keys do
+ begin
+ for i:=Pred(Count) downto 0 do
+ begin
+ if Pos(Header,Strings[i])=1 then
+ CleanKey(Strings[i]);
+ end;
+ Free;
+ end;
+end;
+
+function JSONObject.RemoveLastKey: TZAbstractObject;
+var
+ i:Integer;
+begin
+ with myHashMap do
+ begin
+ i:=length-1;
+ if i<0 then
+ begin
+ Result:=nil;
+ exit;
+ end;
+ Result:=TZAbstractObject(Objects[i]);
+ delete(i);
+ end;
+end;
+
+function JSONObject.PropCount: Integer;
+begin
+ Result:=myHashMap.Count;
+end;
+
+function JSONObject.KeyByVal(const Value: String): String;
+var
+ i:Integer;
+begin
+ for i:=0 to Pred(myHashMap.Count) do
+ begin
+ with TZAbstractObject(myHashMap.Objects[i]) do
+ begin
+ if toString=Value then
+ begin
+ Result:=myHashMap[i];
+ exit;
+ end;
+ end;
+ end;
+ Result:='';
+end;
+
+function JSONObject.PartExtract(KeyNames: TStrings;
+ DoRemove: Boolean): JSONObject;
+var
+ i:Integer;
+ KeyName:String;
+begin
+ Result:=nil;
+ if KeyNames=nil then exit;
+ Result:=JSONObject.Create;
+ for i:=Pred(Length) downto 0 do
+ begin
+ KeyName:=KeyByIndex[i];
+ if KeyNames.IndexOf(KeyName)<0 then continue;
+ if DoRemove then
+ Result.Put(KeyName,Remove(KeyByIndex[i]))
+ else
+ Result.Put(KeyName,ValObjByIndex[i].Clone);
+ end;
+end;
+
+function JSONObject.ExtractAll: JSONObject;
+var
+ i:Integer;
+ KeyName:String;
+begin
+ Result:=JSONObject.Create;
+ for i:=Pred(Length) downto 0 do
+ begin
+ KeyName:=KeyByIndex[i];
+ Result.Put(KeyName,Remove(KeyByIndex[i]))
+ end;
+end;
+
+function JSONObject.TryNewJSONArray(const Key: String): JSONArray;
+begin
+ Result:=OptJSONArray(Key);
+ if Result=nil then
+ begin
+ Result:=JSONArray.create;
+ Result.Parent := Self;
+ Put(Key,Result);
+ end;
+end;
+
+function JSONObject.TryNewJSONObject(const Key: String): JSONObject;
+begin
+ Result:=OptJSONObject(Key);
+ if Result=nil then
+ begin
+ Result:=JSONObject.create;
+ Result.Parent := Self;
+ Put(Key,Result);
+ end;
+end;
+
+procedure JSONObject.Assign(Source: JSONObject);
+begin
+ if Source=nil then
+ Clean
+ else begin
+ AsString:=Source.AsString;
+ end;
+end;
+
+function JSONObject.GetKeyByIndex(index: Integer): String;
+begin
+ Result:=myHashMap[index];
+end;
+
+function JSONObject.GetObject(const key: string): TObject;
+begin
+ Result:=OptObject(Key);
+end;
+
+procedure JSONObject.SetCascadeValue(const Value: String;
+ const Keys: array of String);
+begin
+ SetCascadeValueEx(Value,Keys,0);
+end;
+
+procedure JSONObject.SetCascadeValueEx(const Value: String;
+ const Keys: array of String; StartIdx: Integer);
+var
+ JObj:JSONObject;
+begin
+ if High(Keys)CNULL) and (temp<>CONST_FALSE) and (temp<>CONST_TRUE) and (temp <> nil) then //Prevent to free const obj. By craetion_zy 2009-11-21
+ temp.free;
+end;
+
+function JSONObject.SetKey(idx: Integer; const Key: String): Boolean;
+begin
+ Result:=myHashMap.IndexOf(Key)<0;
+ if not Result or (idx<0) or (idx>=myHashMap.Count) then exit;
+ myHashMap.Strings[idx]:=Key;
+end;
+
+function JSONObject.GetValByIndex(index: Integer): String;
+begin
+ Result:=TZAbstractObject(myHashMap.Objects[index]).toString;
+end;
+
+function JSONObject.GetValObjByIndex(index: Integer): TZAbstractObject;
+begin
+ Result:=TZAbstractObject(myHashMap.Objects[index]);
+end;
+
+procedure JSONObject.CleanKey(const Key: String);
+var
+ i:Integer;
+begin
+ i:=myHashMap.IndexOf(key);
+ if i<0 then exit;
+ SafeFreeJObj(myHashMap.Objects[i]);
+ myHashMap.delete(i);
+end;
+
+procedure JSONObject.UpdateByTokener(x: JSONTokener);
+var
+ c: char;
+begin
+ FName:=''; // by yangyxd
+
+ if (x.nextClean() <> '{') then
+ raise x.syntaxError('A JSONObject must begin with "{"');
+ while (true) do
+ begin
+ c:=x.nextClean();
+ case (c) of
+ #0:
+ raise x.syntaxError('A JSONObject must end with "}"');
+ '}': begin
+ exit;
+ end
+ else begin
+ {$IFDEF BACK_OPT}if x.myIndex>1 then Dec(x.myIndex);{$ELSE}x.back();{$ENDIF}
+ //key:=x.nextValue().toString();
+ with x.nextValue(self) do
+ begin
+ FName:=toString(); // by yangyxd
+ Free; //Fix memory leak. By creation_zy 2008-08-07
+ end;
+ end
+ end; //fim do case
+
+ (*
+ * The key is followed by ':'. We will also tolerate '=' or '=>'.
+ *)
+
+ c:=x.nextClean();
+ if (c = '=') then begin
+ if (x.next() <> '>') then begin
+ {$IFDEF BACK_OPT}if x.myIndex>1 then Dec(x.myIndex);{$ELSE}x.back();{$ENDIF}
+ end;
+ end else if (c <> ':') then begin
+ raise x.syntaxError('Expected a ":" after a key');
+ end;
+ self.myHashMap.AddObject(FName, x.nextValue(self)); // by yangyxd
+
+ (*
+ * Pairs are separated by ','. We will also tolerate ';'.
+ *)
+
+ case (x.nextClean()) of
+ ';', ',': begin
+ if (x.nextClean() = '}') then begin
+ exit;
+ end;
+ {$IFDEF BACK_OPT}if x.myIndex>1 then Dec(x.myIndex);{$ELSE}x.back();{$ENDIF}
+ end;
+ '}': begin
+ exit;
+ end
+ else begin
+ raise x.syntaxError('Expected a "," or "}"');
+ end
+ end;
+ end; //while
+end;
+
+function JSONObject.UpSibling: JSONObject;
+var
+ i: Integer;
+begin
+ if not Assigned(Parent) then
+ Result := nil
+ else begin
+ i := Parent.IndexOfObject(Self) - 1;
+ if (i > -1) and (i < Parent.Count - 1) and (Parent.Child[i] is JSONObject) then begin
+ Result := JSONObject(Parent.Child[i])
+ end else
+ Result := nil;
+ end;
+end;
+
+{ _Boolean }
+
+function _Boolean.boolValue: Boolean;
+begin
+ Result:=fvalue;
+end;
+
+function _Boolean.Clone: TZAbstractObject;
+begin
+ Result:=_Boolean.create(Self.fvalue);
+end;
+
+constructor _Boolean.create(b: boolean);
+begin
+ fvalue:=b;
+end;
+
+function _Boolean.toString: string;
+begin
+ if fvalue then
+ Result:='true'
+ else
+ Result:='false';
+end;
+
+class function _Boolean.valueOf(b: boolean): _Boolean;
+begin
+ if (b) then
+ Result:=_TRUE
+ else
+ Result:=_FALSE;
+end;
+
+class function _Boolean._FALSE: _Boolean;
+begin
+ Result:=CONST_FALSE;
+end;
+
+class function _Boolean._TRUE: _Boolean;
+begin
+ Result:=CONST_TRUE;
+end;
+
+{ _String }
+
+function _String.Clone: TZAbstractObject;
+begin
+ Result:=_String.create (self.fvalue);
+end;
+
+constructor _String.create(const s: string);
+begin
+ fvalue:=s;
+end;
+
+
+function _String.equals(const Value: TZAbstractObject): Boolean;
+begin
+ Result:=(value is _String) and (_String (value).fvalue = fvalue);
+end;
+
+function _String.equalsIgnoreCase(const s: string): boolean;
+begin
+ Result:=AnsiLowerCase (s) = AnsiLowerCase (fvalue);
+end;
+
+function _String.GetAsString: String;
+begin
+ Result:=fvalue;
+end;
+
+procedure _String.SetAsString(const Value: String);
+begin
+ fvalue:=Value;
+end;
+
+function _String.toString: string;
+begin
+ Result:=fvalue;
+end;
+
+{ ParseException }
+
+constructor ParseException.create(_message: string; index: integer);
+begin
+ inherited createFmt(_message+#10#13' erro no caracter: %d',[index]);
+end;
+
+{ _Integer }
+
+constructor _Integer.create(i: integer);
+begin
+ fvalue:=i;
+end;
+
+function _Integer.Clone: TZAbstractObject;
+begin
+ Result:=_Integer.create(self.fvalue);
+end;
+
+constructor _Integer.create(const s: string);
+begin
+ fvalue:=strToInt64(s);
+end;
+
+constructor _Integer.create(i: int64);
+begin
+ fvalue := i;
+end;
+
+function _Integer.doubleValue: double;
+begin
+ Result:=fvalue;
+end;
+
+function _Integer.int64Value: Int64;
+begin
+ Result := fvalue;
+end;
+
+function _Integer.intValue: integer;
+begin
+ Result:=fvalue;
+end;
+
+
+
+class function _Integer.parseInt(const s: string; i: integer): integer;
+begin
+ Result:=0; //By creation_zy
+ case i of
+ 10: Result:=strToInt(s);
+ 16: Result:=hexToInt(s);
+ 8:
+ begin
+ if s='0' then exit; //By creation_zy
+ newNotImplmentedFeature() ;
+ end;
+ else newNotImplmentedFeature() ; //By creation_zy
+ end;
+end;
+
+class function _Integer.parseInt(s: _String): integer;
+begin
+ Result:=_Integer.parseInt(s.toString, 10);
+end;
+
+class function _Integer.parseInt64(s: _String): int64;
+begin
+ Result:=_Integer.parseInt64(s.toString);
+end;
+
+class function _Integer.parseInt64(const s: string): int64;
+begin
+ Result := strToInt64(s);
+end;
+
+class function _Integer.toHexString(c: char): string;
+begin
+ Result:=IntToHex(ord(c),2);
+end;
+
+function _Integer.toString: string;
+begin
+ Result:=intToStr(fvalue);
+end;
+
+
+{ _Double }
+
+constructor _Double.create(const s: string);
+begin
+ fvalue:=StrToFloat(s, getFormatSettings);
+end;
+
+constructor _Double.create(s: _String);
+begin
+ create (s.toString);
+end;
+
+
+function _Double.Clone: TZAbstractObject;
+begin
+ Result:=_Double.create(Self.fvalue);
+end;
+
+constructor _Double.create(d: double);
+begin
+ fvalue:=d;
+end;
+
+function _Double.doubleValue: double;
+begin
+ Result:=fvalue;
+end;
+
+function _Double.int64Value: Int64;
+begin
+ Result := Trunc(fvalue);
+end;
+
+function _Double.intValue: integer;
+begin
+ Result:=trunc(fvalue);
+end;
+
+class function _Double.NaN: double;
+begin
+ Result:=3.6e-4951;
+end;
+
+function _Double.toString: string;
+begin
+ Result:=floatToStr(fvalue, getFormatSettings);
+end;
+
+{ JSONArray }
+
+(**
+ * Construct a JSONArray from a JSONTokener.
+ * @param x A JSONTokener
+ * @exception ParseException A JSONArray must start with '['
+ * @exception ParseException Expected a ',' or ']'
+ *)
+constructor JSONArray.create(x: JSONTokener);
+var
+ Ch:Char;
+begin
+ create;
+ if (x.nextClean() <> '[') then
+ raise x.syntaxError('A JSONArray must start with "["');
+ //if (x.nextClean() = ']') then exit;
+ //{$IFDEF BACK_OPT}if x.myIndex>1 then Dec(x.myIndex);{$ELSE}x.back();{$ENDIF}
+ Ch:=x.nextClean();
+ if Ch=']' then exit;
+ while true do
+ begin
+ if (Ch = ',') then begin
+ {$IFDEF BACK_OPT}if x.myIndex>1 then Dec(x.myIndex);{$ELSE}x.back();{$ENDIF}
+ myArrayList.add(nil);
+ end
+ else begin
+ {$IFDEF BACK_OPT}if x.myIndex>1 then Dec(x.myIndex);{$ELSE}x.back();{$ENDIF}
+ myArrayList.add(x.nextValue(self));
+ end;
+ case x.nextClean() of
+ ';',',':
+ begin
+ if (x.nextClean() = ']') then exit;
+ {$IFDEF BACK_OPT}if x.myIndex>1 then Dec(x.myIndex);{$ELSE}x.back();{$ENDIF}
+ end;
+ ']': exit;
+ else raise x.syntaxError('Expected a "," or "]"');
+ end;
+ Ch:=x.nextClean();
+ end;
+end;
+
+destructor JSONObject.destroy;
+var
+ i :integer;
+ MyObj:TObject;
+begin
+ for i:=Pred(myHashMap.Count) downto 0 do
+ begin
+ MyObj:=myHashMap.Objects[i];
+ SafeFreeJObj(MyObj);
+ end;
+ myHashMap.Free;
+ inherited;
+end;
+
+(**
+ * Construct a JSONArray from a Collection.
+ * @param collection A Collection.
+ *)
+constructor JSONArray.create(collection: TList);
+var
+ i: integer;
+begin
+ inherited Create;
+ myArrayList:=TList.create ();
+ for i:=0 to collection.count -1 do begin
+ myArrayList.add (collection[i]);
+ end;
+end;
+
+(**
+ * Construct an empty JSONArray.
+*)
+constructor JSONArray.create;
+begin
+ inherited Create;
+ myArrayList:=TList.create;
+end;
+
+
+(**
+ * Construct a JSONArray from a source string.
+ * @param string A string that begins with
+ * [ (left bracket)
+ * and ends with ] (right bracket).
+ * @exception ParseException The string must conform to JSON syntax.
+ *)
+constructor JSONArray.create(const s: string);
+var
+ token:JSOnTokener;
+begin
+ token:=JSONTokener.create(s);
+ try
+ create(token);
+ finally
+ token.free;
+ end;
+end;
+
+destructor JSONArray.destroy;
+var
+ i: integer;
+begin
+ for i:=Pred(myArrayList.Count) downto 0 do
+ SafeFreeJObj(myArrayList[i]);
+ myArrayList.Free;
+ inherited;
+end;
+
+procedure JSONArray.Assign(Source: JSONArray);
+begin
+ Clean;
+ appendJSONArray(Source);
+end;
+
+procedure JSONArray.Clean;
+var
+ i: integer;
+begin
+ for i:=Pred(myArrayList.Count) downto 0 do
+ SafeFreeJObj(myArrayList[i]);
+ myArrayList.Clear; //2009-12-10 By creation_zy
+end;
+
+function JSONArray.Clone: TZAbstractObject;
+begin
+ Result:=JSONArray.create(Self.toString);
+end;
+
+function JSONArray.appendJSONArray(value: JSONArray): Integer;
+var
+ i:Integer;
+begin
+ if value=nil then
+ begin
+ Result:=0;
+ exit;
+ end;
+ Result:=value.length;
+ for i:=0 to Pred(Result) do
+ put(value.get(i).Clone);
+end;
+
+(**
+ * Get the object value associated with an index.
+ * @param index
+ * The index must be between 0 and length() - 1.
+ * @return An object value.
+ * @exception NoSuchElementException
+ *)
+function JSONArray.get(index: integer): TZAbstractObject;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if (o = nil) then
+ raise NoSuchElementException.create('JSONArray[' + intToStr(index)
+ + '] not found.');
+ Result:=o;
+end;
+
+
+(**
+ * Get the boolean value associated with an index.
+ * The string values "true" and "false" are converted to boolean.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return The truth.
+ * @exception NoSuchElementException if the index is not found
+ * @exception ClassCastException
+ *)
+function JSONArray.getBoolean(index: integer): boolean;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(index);
+ if ((o.equals(_Boolean._FALSE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('false')))) then begin
+ Result:=false;
+ exit;
+ end else if ((o.equals(_Boolean._TRUE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('true')))) then begin
+ Result:=true;
+ exit;
+ end;
+ raise ClassCastException.create('JSONArray[' + intToStr(index) +
+ '] not a Boolean.');
+end;
+
+function JSONArray.GetChild(Index: Integer): TZAbstractObject;
+begin
+ Result:=opt(index);
+end;
+
+function JSONArray.GetCount: Integer;
+begin
+ Result := myArrayList.Count;
+end;
+
+(**
+ * Get the double value associated with an index.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return The value.
+ * @exception NoSuchElementException if the key is not found
+ * @exception NumberFormatException
+ * if the value cannot be converted to a number.
+ *)
+function JSONArray.getDouble(index: integer): double;
+var
+ o: TZAbstractObject;
+ d: _Double;
+begin
+ o:=get(index);
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).doubleValue();
+ exit;
+ end;
+ if (o is _String) then
+ begin
+ d:= _Double.create(_String(o));
+ try
+ Result:=d.doubleValue();
+ exit;
+ finally
+ d.Free;
+ end;
+ end;
+ raise NumberFormatException.create('JSONObject['
+ + intToStr(index) + '] is not a number.');
+end;
+
+
+(**
+ * Get the int value associated with an index.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return The value.
+ * @exception NoSuchElementException if the key is not found
+ * @exception NumberFormatException
+ * if the value cannot be converted to a number.
+ *)
+function JSONArray.getInt(index: integer): integer;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(index);
+ if (o is _Number) then
+ Result:=_Number(o).intValue()
+ else
+ Result:=trunc(getDouble(index));
+end;
+
+
+function JSONArray.getInt64(index: integer): int64;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(index);
+ if (o is _Number) then
+ Result:=_Number(o).int64Value()
+ else
+ Result:=trunc(getDouble(index));
+end;
+
+(**
+ * Get the JSONArray associated with an index.
+ * @param index The index must be between 0 and length() - 1.
+ * @return A JSONArray value.
+ * @exception NoSuchElementException if the index is not found or if the
+ * value is not a JSONArray
+ *)
+function JSONArray.getJSONArray(index: integer): JSONArray;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(index);
+ if (o is JSONArray) then
+ begin
+ Result:=JSONArray(o);
+ exit;
+ end;
+ raise NoSuchElementException.create('JSONArray[' + intToStr(index) +
+ '] is not a JSONArray.');
+end;
+
+
+(**
+ * Get the JSONObject associated with an index.
+ * @param index subscript
+ * @return A JSONObject value.
+ * @exception NoSuchElementException if the index is not found or if the
+ * value is not a JSONObject
+ *)
+function JSONArray.getJSONObject(index: integer): JSONObject;
+var
+ o: TZAbstractObject;
+ s: string;
+begin
+ o:=get(index);
+ if (o is JSONObject) then
+ Result:=JSONObject(o)
+ else begin
+ if o <> nil then
+ s:=o.ClassName
+ else
+ s:='nil';
+ raise NoSuchElementException.create('JSONArray[' + intToStr(index) +
+ '] is not a JSONObject is ' + s);
+ end;
+end;
+
+(**
+ * Get the string associated with an index.
+ * @param index The index must be between 0 and length() - 1.
+ * @return A string value.
+ * @exception NoSuchElementException
+ *)
+function JSONArray.getString(index: integer): string;
+begin
+ Result:=get(index).toString();
+end;
+
+function JSONArray.IndexOfObject(aobj: TObject): Integer;
+var i: Integer;
+begin
+ for i := 0 to myArrayList.Count - 1 do
+ if opt(i) = aobj then begin
+ Result := I;
+ Exit;
+ end;
+ Result := -1;
+end;
+
+(**
+ * Determine if the value is null.
+ * @param index The index must be between 0 and length() - 1.
+ * @return true if the value at the index is null, or if there is no value.
+ *)
+
+function JSONArray.isNull(index: integer): boolean;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ Result:=(o = nil) or (o.equals(nil));
+end;
+
+(**
+ * Make a string from the contents of this JSONArray. The separator string
+ * is inserted between each element.
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param separator A string that will be inserted between the elements.
+ * @return a string.
+ *)
+function JSONArray.join(separator: string): string;
+var
+ len, i: integer;
+ sb: string ;
+begin
+ len:=length();
+ sb:='';
+ for i:=0 to len -1 do
+ begin
+ if (i > 0) then
+ sb:=sb + separator;
+ sb:= sb + JSONObject.valueToString(TZAbstractObject(myArrayList[i]));
+ end;
+ Result:=sb;
+end;
+
+function JSONArray.LastItem: TZAbstractObject;
+var
+ Len:Integer;
+begin
+ Len:=length();
+ if Len=0 then
+ Result:=nil
+ else
+ Result:=TZAbstractObject(TZAbstractObject(myArrayList[Len-1]));
+end;
+
+(**
+ * Get the length of the JSONArray.
+ *
+ * @return The length (or size).
+ *)
+function JSONArray.length: integer;
+begin
+ Result:=myArrayList.Count;
+end;
+
+ (**
+ * Get the optional object value associated with an index.
+ * @param index The index must be between 0 and length() - 1.
+ * @return An object value, or null if there is no
+ * object at that index.
+ *)
+function JSONArray.opt(index: integer): TZAbstractObject;
+begin
+ if ((index < 0) or (index >= length()) ) then
+ Result:=nil
+ else
+ Result:=TZAbstractObject (myArrayList[index]);
+end;
+
+(**
+ * Get the optional boolean value associated with an index.
+ * It returns false if there is no value at that index,
+ * or if the value is not Boolean.TRUE or the String "true".
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return The truth.
+ *)
+function JSONArray.optBoolean(index: integer): boolean;
+begin
+ Result:=optBoolean(index, false);
+end;
+
+(**
+ * Get the optional boolean value associated with an index.
+ * It returns the defaultValue if there is no value at that index or if it is not
+ * a Boolean or the String "true" or "false" (case insensitive).
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @param defaultValue A boolean default.
+ * @return The truth.
+ *)
+function JSONArray.optBoolean(index: integer;
+ defaultValue: boolean): boolean;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if (o <> nil) then
+ begin
+ if ((o.equals(_Boolean._FALSE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('false')))) then begin
+ Result:=false;
+ exit;
+ end
+ else if ((o.equals(_Boolean._TRUE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('true')))) then begin
+ Result:=true;
+ exit;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+
+(**
+ * Get the optional double value associated with an index.
+ * NaN is returned if the index is not found,
+ * or if the value is not a number and cannot be converted to a number.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return The value.
+ *)
+function JSONArray.optDouble(index: integer): double;
+begin
+ Result:=optDouble(index, _Double.NaN);
+end;
+
+(**
+ * Get the optional double value associated with an index.
+ * The defaultValue is returned if the index is not found,
+ * or if the value is not a number and cannot be converted to a number.
+ *
+ * @param index subscript
+ * @param defaultValue The default value.
+ * @return The value.
+ *)
+function JSONArray.optDouble(index: integer; defaultValue :double): double;
+var
+ o: TZAbstractObject;
+ d: _Double;
+begin
+ o:=opt(index);
+ if (o <> nil) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).doubleValue();
+ exit;
+ end;
+ try
+ d:=_Double.create (_String (o));
+ Result:=d.doubleValue ;
+ d.Free;
+ exit;
+ except
+ on e:Exception do
+ begin
+ Result:=defaultValue;
+ exit;
+ end;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+(**
+ * Get the optional int value associated with an index.
+ * Zero is returned if the index is not found,
+ * or if the value is not a number and cannot be converted to a number.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return The value.
+ *)
+function JSONArray.optInt(index: integer): integer;
+begin
+ Result:=optInt(index, 0);
+end;
+
+
+(**
+ * Get the optional int value associated with an index.
+ * The defaultValue is returned if the index is not found,
+ * or if the value is not a number and cannot be converted to a number.
+ * @param index The index must be between 0 and length() - 1.
+ * @param defaultValue The default value.
+ * @return The value.
+ *)
+function JSONArray.optInt(index, defaultValue: integer): integer;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if (o <> nil) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).intValue();
+ exit; //By creation_zy
+ end;
+ try
+ Result:=_Integer.parseInt(_String(o));
+ exit;
+ except
+ on e: exception do
+ begin
+ Result:=defaultValue;
+ exit;
+ end;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+
+function JSONArray.OptInt64(index: integer): int64;
+begin
+ Result := OptInt64(index, 0);
+end;
+
+function JSONArray.OptInt64(index: integer; defaultValue: int64): int64;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if (o <> nil) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).int64Value();
+ exit; //By creation_zy
+ end;
+ try
+ Result:=_Integer.parseInt64(_String(o));
+ exit;
+ except
+ on e: exception do
+ begin
+ Result:=defaultValue;
+ exit;
+ end;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+(**
+ * Get the optional JSONArray associated with an index.
+ * @param index subscript
+ * @return A JSONArray value, or null if the index has no value,
+ * or if the value is not a JSONArray.
+ *)
+function JSONArray.optJSONArray(index: integer): JSONArray;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if (o is JSONArray) then
+ Result:=JSONArray(o)
+ else
+ Result:=nil;
+end;
+
+(**
+ * Get the optional JSONObject associated with an index.
+ * Null is returned if the key is not found, or null if the index has
+ * no value, or if the value is not a JSONObject.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return A JSONObject value.
+ *)
+function JSONArray.optJSONObject(index: integer): JSONObject;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if o is JSONObject then
+ Result:=JSONObject(o)
+ else
+ Result:=nil;
+end;
+
+{$IFDEF J_OBJECT}
+function JSONArray.optObject(index: integer): TObject;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if o is _Object then
+ Result:=_Object(o).fvalue
+ else
+ Result:=nil;
+end;
+{$ENDIF}
+
+(**
+ * Get the optional string value associated with an index. It returns an
+ * empty string if there is no value at that index. If the value
+ * is not a string and is not null, then it is coverted to a string.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @return A String value.
+ *)
+function JSONArray.optString(index: integer): string;
+begin
+ Result:=optString(index, '');
+end;
+
+(**
+ * Get the optional string associated with an index.
+ * The defaultValue is returned if the key is not found.
+ *
+ * @param index The index must be between 0 and length() - 1.
+ * @param defaultValue The default value.
+ * @return A String value.
+ *)
+function JSONArray.optString(index: integer; defaultValue: string): string;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(index);
+ if (o <> nil) then
+ Result:=o.toString()
+ else
+ Result:=defaultValue;
+end;
+
+(**
+ * Append a boolean value.
+ *
+ * @param value A boolean value.
+ * @return this.
+ *)
+function JSONArray.put(value: boolean): JSONArray;
+begin
+ put(_Boolean.valueOf(value));
+ Result:= self;
+end;
+
+(**
+ * Append a double value.
+ *
+ * @param value A double value.
+ * @return this.
+ *)
+function JSONArray.put(value: double): JSONArray;
+begin
+ put(_Double.create(value));
+ Result:=self;
+end;
+
+(**
+ * Append an int value.
+ *
+ * @param value An int value.
+ * @return this.
+ *)
+function JSONArray.put(value: integer): JSONArray;
+begin
+ put(_Integer.create(value));
+ Result:=self;
+end;
+
+
+function JSONArray.put(value: string): JSONArray;
+begin
+ put (_String.create (value));
+ Result:=self;
+end;
+
+{$IFDEF J_OBJECT}
+function JSONArray.put ( value: TObject): JSONArray;
+begin
+ put (_Object.create (value));
+ Result:=self;
+end;
+{$ENDIF}
+
+(**
+ * Append an object value.
+ * @param value An object value. The value should be a
+ * Boolean, Double, Integer, JSONArray, JSObject, or String, or the
+ * JSONObject.NULL object.
+ * @return this.
+ *)
+function JSONArray.put(value: TZAbstractObject): JSONArray;
+begin
+ myArrayList.add(value);
+ Result:=self;
+end;
+
+(**
+ * Put or replace a boolean value in the JSONArray.
+ * @param index subscript The subscript. If the index is greater than the length of
+ * the JSONArray, then null elements will be added as necessary to pad
+ * it out.
+ * @param value A boolean value.
+ * @return this.
+ * @exception NoSuchElementException The index must not be negative.
+ *)
+function JSONArray.put(index: integer; value: boolean): JSONArray;
+begin
+ put(index, _Boolean.valueOf(value));
+ Result:=self;
+end;
+
+function JSONArray.put(index, value: integer): JSONArray;
+begin
+ put(index, _Integer.create(value));
+ Result:=self;
+end;
+
+
+function JSONArray.put(index: integer; value: double): JSONArray;
+begin
+ put(index, _Double.create(value));
+ Result:=self;
+end;
+
+function JSONArray.put(index: integer; value: string): JSONArray;
+begin
+ put (index,_String.create (value));
+ Result:=self;
+end;
+
+(**
+ * Put or replace an object value in the JSONArray.
+ * @param index The subscript. If the index is greater than the length of
+ * the JSONArray, then null elements will be added as necessary to pad
+ * it out.
+ * @param value An object value.
+ * @return this.
+ * @exception NoSuchElementException The index must not be negative.
+ * @exception NullPointerException The index must not be null.
+ *)
+function JSONArray.put(index: integer; value: TZAbstractObject): JSONArray;
+begin
+ if (index < 0) then
+ raise NoSuchElementException.create('JSONArray['+intToStr(index)+'] not found.')
+ else if (value = nil) then
+ raise NullPointerException.create('')
+ else if (index < length()) then
+ myArrayList[index]:=value
+ else begin
+ while (index<>length()) do put(nil);
+ put(value);
+ end;
+ Result:=self;
+end;
+
+{$IFDEF J_OBJECT}
+function JSONArray.put(index: integer; value: TObject): JSONArray;
+begin
+ put (index,_Object.create(value));
+ Result:=self;
+end;
+
+function JSONArray.put(index: integer; value: int64): JSONArray;
+begin
+ put(index, _Integer.create(value));
+ Result:=self;
+end;
+
+procedure JSONArray.SetChild(Index: Integer; const Value: TZAbstractObject);
+begin
+ put(index, Value);
+end;
+
+{$ENDIF}
+
+(**
+ * Produce a JSONObject by combining a JSONArray of names with the values
+ * of this JSONArray.
+ * @param names A JSONArray containing a list of key strings. These will be
+ * paired with the values.
+ * @return A JSONObject, or null if there are no names or if this JSONArray
+ * has no values.
+ *)
+function JSONArray.toJSONObject(names :JSONArray): JSONObject;
+var
+ i: integer;
+begin
+ if ((names = nil) or (names.length() = 0) or (length() = 0)) then
+ begin
+ Result:=nil;
+ exit; //By creation_zy
+ end;
+ Result:=JSONObject.create();
+ for i:=0 to names.length() do
+ Result.put(names.getString(i), self.opt(i));
+end;
+
+
+(**
+ * Make an JSON external form string of this JSONArray. For compactness, no
+ * unnecessary whitespace is added.
+ * Warning: This method assumes that the data structure is acyclical.
+ *
+ * @return a printable, displayable, transmittable
+ * representation of the array.
+ *)
+function JSONArray.toString: string;
+begin
+ Result:='[' + join(',') + ']';
+end;
+
+(**
+ * Make a prettyprinted JSON string of this JSONArray.
+ * Warning: This method assumes that the data structure is non-cyclical.
+ * @param indentFactor The number of spaces to add to each level of
+ * indentation.
+ * @return a printable, displayable, transmittable
+ * representation of the object, beginning
+ * with [ (left bracket) and ending
+ * with ] (right bracket).
+ *)
+function JSONArray.toString2(indentFactor: integer): string;
+begin
+ Result:=toString3(indentFactor, 0);
+end;
+
+(**
+ * Make a prettyprinted string of this JSONArray.
+ * Warning: This method assumes that the data structure is non-cyclical.
+ * @param indentFactor The number of spaces to add to each level of
+ * indentation.
+ * @param indent The indention of the top level.
+ * @return a printable, displayable, transmittable
+ * representation of the array.
+ *)
+function JSONArray.toList: TList;
+begin
+ Result:=TList.create ;
+ Result.Assign(myArrayList,laCopy);
+end;
+
+function JSONArray.toString3(indentFactor, indent: integer): string;
+var
+ len, i, newindent: integer;
+ sb: string;
+begin
+ len:=length();
+ if (len = 0) then
+ begin
+ Result:='[]';
+ exit;
+ end;
+ sb:='[';
+ if (len = 1) then
+ begin
+ sb:=sb + JSONObject
+ .valueToString(TZAbstractObject( myArrayList[0]),indentFactor, indent);
+ end
+ else begin
+ newindent:=indent + indentFactor;
+ sb:=sb + #10 ;
+ for i:=0 to len -1 do
+ begin
+ if i > 0 then
+ sb:=sb +',' + #10;
+ sb:=sb + SpaceStr(newindent) + (JSONObject.valueToString(TZAbstractObject(myArrayList[i]),
+ indentFactor, newindent));
+ end;
+ sb:=sb + #10 + SpaceStr(indent);
+ end;
+ sb:=sb + ']';
+ Result:=sb;
+end;
+
+
+{ _NULL }
+
+function _NULL.Clone: TZAbstractObject;
+begin
+ Result:=CNULL;
+end;
+
+function _NULL.Equals(const Value: TZAbstractObject): Boolean;
+begin
+ if (value = nil) then
+ Result:=true
+ else
+ Result:=(value is _NULL);
+end;
+
+function _NULL.toString: string;
+begin
+ Result:='null';
+end;
+
+
+{ TZAbstractObject }
+
+class procedure TZAbstractObject.WriteChar(avOut: TStream; const avData: Char);
+begin
+ avOut.WriteBuffer(avData, SizeOf(Char));
+end;
+
+class procedure TZAbstractObject.WriteString(avOut: TStream; const avData: string);
+var
+ l: Cardinal;
+begin
+ l := Length(avData);
+ if l > 0 then
+ avOut.WriteBuffer(avData[1], l);
+end;
+
+class procedure TZAbstractObject.WriteText(avOut: TStream; const avData: string;
+ len: Integer);
+begin
+ if len > 0 then
+ avOut.WriteBuffer(avData[1], len);
+end;
+
+function TZAbstractObject.Clone: TZAbstractObject;
+begin
+ Result:=nil;
+ newNotImplmentedFeature();
+end;
+
+function TZAbstractObject.Equals(const Value: TZAbstractObject): Boolean;
+begin
+ Result:=(value <> nil) and (value = self);
+end;
+
+procedure TZAbstractObject.Free;
+begin
+ SafeFreeJObj(Self);
+end;
+
+class function TZAbstractObject.getBoolean(o: TZAbstractObject; DefaultValue: Boolean): Boolean;
+begin
+ if (o<>CNULL) and (o<>nil) then
+ begin
+ if o.ClassType=_Boolean then //2009-03-06 By creation_zy
+ begin
+ Result:=_Boolean(o).fvalue;
+ exit;
+ end
+ else if ((o is _String) and (_String(o).equalsIgnoreCase('false'))) then
+ begin
+ Result:=false;
+ exit;
+ end
+ else if ((o is _String) and (_String(o).equalsIgnoreCase('true'))) then
+ begin
+ Result:=true;
+ exit;
+ end;
+ end;
+ Result:=DefaultValue;
+end;
+
+class function TZAbstractObject.getDouble(o: TZAbstractObject; DefaultValue: Double): Double;
+begin
+ if (o<>CNULL) and ( o <> nil ) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:= _Number(o).doubleValue();
+ exit;
+ end;
+ if o.ClassType=_String then
+ Result:=StrToFloatDef(o.toString,DefaultValue)
+ else
+ Result:=defaultValue;
+ end
+ else //By creation_zy
+ Result:=defaultValue;
+end;
+
+class function TZAbstractObject.getInt(o: TZAbstractObject; DefaultValue: Integer): Integer;
+begin
+ if (o<>CNULL) and ( o <> nil ) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:=_Number(o).intValue();
+ exit;
+ end;
+ if o.ClassType<>_String then
+ Result:=defaultValue
+ else
+ try
+ Result:=_Integer.parseInt(_String(o));
+ except
+ Result:=defaultValue;
+ end;
+ end
+ else //By creation_zy
+ Result:=defaultValue;
+end;
+
+class function TZAbstractObject.getInt64(o: TZAbstractObject;
+ DefaultValue: Int64): Int64;
+begin
+ if (o<>CNULL) and ( o <> nil ) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:=_Number(o).int64Value();
+ exit;
+ end;
+ if o.ClassType<>_String then
+ Result:=defaultValue
+ else
+ try
+ Result:=_Integer.parseInt64(_String(o));
+ except
+ Result:=defaultValue;
+ end;
+ end
+ else //By creation_zy
+ Result:=defaultValue;
+end;
+
+function TZAbstractObject.Hash: LongInt;
+begin
+ Result:=integer(addr(self));
+end;
+
+function TZAbstractObject.InstanceOf(
+ const Value: TZAbstractObject): Boolean;
+begin
+ Result:=value is TZAbstractObject;
+end;
+
+procedure TZAbstractObject.SaveToStream(stream: TStream);
+begin
+ WriteString(stream, Format('%s <%p>', [ClassName, addr(Self)]));
+end;
+
+function TZAbstractObject.toJSONArray: JSONArray;
+begin
+ if Self is JSONArray then
+ Result := JSONArray(Self)
+ else
+ Result := nil;
+end;
+
+function TZAbstractObject.toJSONObject: JSONObject;
+begin
+ if Self is JSONObject then
+ Result := JSONObject(Self)
+ else
+ Result := nil;
+end;
+
+function TZAbstractObject.ToString: string;
+begin
+ Result:=Format('%s <%p>', [ClassName, addr(Self)]);
+end;
+
+{$IFDEF J_OBJECT}
+{ _Object }
+
+function _Object.Clone: TZAbstractObject;
+begin
+ Result:=_Object.Create(fvalue);
+end;
+
+constructor _Object.Create(value: TObject);
+begin
+ fvalue:=value;
+end;
+
+function _Object.Equals(const Value: TZAbstractObject): Boolean;
+begin
+ Result:=(Value is _Object) and (_Object(Value).AsObject=AsObject);
+end;
+
+procedure _Object.SetAsObject(const Value: TObject);
+begin
+ fvalue:=Value;
+end;
+
+function _Object.toString: string;
+begin
+ if fvalue=nil then
+ Result:=''
+ else
+ Result:=fvalue.ClassName+'::'+IntToHex(Integer(fvalue),8);
+end;
+{$ENDIF}
+
+{ JSONBase }
+
+constructor JSONBase.Create;
+begin
+ FParent := nil;
+end;
+
+function JSONBase.GetChild(Index: Integer): TZAbstractObject;
+begin
+ Result := nil;
+end;
+
+function JSONBase.GetCount: Integer;
+begin
+ Result := 0;
+end;
+
+function JSONBase.IndexOfObject(aobj: TObject): Integer;
+begin
+ Result := -1;
+end;
+
+procedure JSONBase.SetChild(Index: Integer; const Value: TZAbstractObject);
+begin
+end;
+
+initialization
+ CONST_FALSE:=_Boolean.Create(false);
+ CONST_TRUE:=_Boolean.Create(true);
+ CNULL:=_NULL.Create;
+
+finalization
+ TObject(CONST_FALSE).Free;
+ TObject(CONST_TRUE).Free;
+ TObject(CNULL).Free;
+
+end.
diff --git "a/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/uLkJSON.pas" "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/uLkJSON.pas"
new file mode 100644
index 0000000..05928f6
--- /dev/null
+++ "b/demo/YxdJson/JSON\345\237\272\346\234\254\346\265\213\350\257\225/uLkJSON.pas"
@@ -0,0 +1,2626 @@
+{
+ LkJSON v1.07
+
+ 06 november 2009
+
+* Copyright (c) 2006,2007,2008,2009 Leonid Koninin
+* leon_kon@users.sourceforge.net
+* All rights reserved.
+*
+* Redistribution and use in source and binary forms, with or without
+* modification, are permitted provided that the following conditions are met:
+* * Redistributions of source code must retain the above copyright
+* notice, this list of conditions and the following disclaimer.
+* * Redistributions in binary form must reproduce the above copyright
+* notice, this list of conditions and the following disclaimer in the
+* documentation and/or other materials provided with the distribution.
+* * Neither the name of the nor the
+* names of its contributors may be used to endorse or promote products
+* derived from this software without specific prior written permission.
+*
+* THIS SOFTWARE IS PROVIDED BY Leonid Koninin ``AS IS'' AND ANY
+* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+* DISCLAIMED. IN NO EVENT SHALL Leonid Koninin BE LIABLE FOR ANY
+* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+ changes:
+
+ v1.07 06/11/2009 * fixed a bug in js_string - thanks to Andrew G. Khodotov
+ * fixed error with double-slashes - thanks to anonymous user
+ * fixed a BOM bug in parser, thanks to jasper_dale
+ v1.06 13/03/2009 * fixed a bug in string parsing routine
+ * looked routine from the Adrian M. Jones, and get some
+ ideas from it; thanks a lot, Adrian!
+ * checked error reported by phpop and fix it in the string
+ routine; also, thanks for advice.
+ v1.05 26/01/2009 + added port to D2009 by Daniele Teti, thanx a lot! really,
+ i haven't the 2009 version, so i can't play with it. I was
+ add USE_D2009 directive below, disabled by default
+ * fixed two small bugs in parsing object: errors with empty
+ object and list; thanx to RSDN's delphi forum members
+ * fixed "[2229135] Value deletion is broken" tracker
+ issue, thanx to anonymous sender provided code for
+ tree version
+ * fixed js_string according to "[1917047] (much) faster
+ js_string Parse" tracker issue by Joao Inacio; a lot of
+ thanx, great speedup!
+
+ v1.04 05/04/2008 + a declaration of Field property moved from TlkJSONobject
+ to TlkJSONbase; thanx for idea to Andrey Lukyanov; this
+ improve objects use, look the bottom of SAMPLE2.DPR
+ * fixed field name in TlkJSONobject to WideString
+ v1.03 14/03/2008 + added a code for generating readable JSON text, sended to
+ me by Kusnassriyanto Saiful Bahri, thanx to him!
+ * from this version, library distributed with BSD
+ license, more pleasure for commercial programmers :)
+ * was rewritten internal storing of objects, repacing
+ hash tables with balanced trees (AA tree, by classic
+ author's variant). On mine machine, with enabled fastmm,
+ tree variant is about 30% slower in from-zero creation,
+ but about 50% faster in parsing; also deletion of
+ objects will be much faster than a hash-one.
+ Hashes (old-style) can be switched on by enabling
+ USE_HASH directive below
+ v1.02 14/09/2007 * fix mistypes in diffrent places; thanx for reports
+ to Aleksandr Fedorov and Tobias Wrede
+ v1.01 18/05/2007 * fix small bug in new text generation routine, check
+ library for leaks by fastmm4; thanx for idea and comments
+ for Glynn Owen
+ v1.00 12/05/2007 * some fixes in new code (mistypes, mistypes...)
+ * also many fixes by ideas of Henri Gourvest - big thanx
+ for him again; he send me code for thread-safe initializing
+ of hash table, some FPC-compatible issues (not tested by
+ myself) and better code for localization in latest
+ delphi versions; very, very big thanx!
+ * rewritten procedure of json text generating, with wich
+ work of it speeds up 4-5 times (on test) its good for
+ a large objects
+ * started a large work for making source code self-doc
+ (not autodoc!)
+ v0.99 10/05/2007 + add functions to list and object:
+ function getInt(idx: Integer): Integer;
+ function getString(idx: Integer): String;
+ function getWideString(idx: Integer):WideString;
+ function getDouble(idx: Integer): Double;
+ function getBoolean(idx: Integer): Boolean;
+ + add overloaded functions to object:
+ function getDouble(nm: String): Double; overload;
+ function getInt(nm: String): Integer; overload;
+ function getString(nm: String): String; overload;
+ function getWideString(nm: String): WideString; overload;
+ function getBoolean(nm: String): Boolean; overload;
+ * changed storing mech of TlkJSONcustomlist descendants from
+ dynamic array to TList; this gives us great speedup with
+ lesser changes; thanx for idea to Henri Gourvest
+ * also reworked hashtable to work with TList, so it also
+ increase speed of work
+ v0.98 09/05/2007 * fix small bug in work with WideStrings(UTF8), thanx to
+ IVO GELOV to description and sources
+ v0.97 10/04/2007 + add capabilities to work with KOL delphi projects; for
+ this will define KOL variable in begin of text; of course,
+ in this case object TlkJSONstreamed is not compiled.
+ v0.96 03/30/2007 + add TlkJSONFuncEnum and method ForEach in all
+ TlkJSONcustomlist descendants
+ + add property UseHash(r/o) to TlkJSONobject, and parameter
+ UseHash:Boolean to object constructors; set it to false
+ allow to disable using of hash-table, what can increase
+ speed of work in case of objects with low number of
+ methods(fields); [by default it is true]
+ + added conditional compile directive DOTNET for use in .Net
+ based delphi versions; remove dot in declaration below
+ (thanx for idea and sample code to Tim Radford)
+ + added property HashOf to TlkHashTable to allow use of
+ users hash functions; on enter is widestring, on exit is
+ cardinal (32 bit unsigned). Original HashOf renamed to
+ DefaultHashOf
+ * hash table object of TlkJSONobject wrapped by property called
+ HashTable
+ * fixed some minor bugs
+ v0.95 03/29/2007 + add object TlkJSONstreamed what descendant of TlkJSON and
+ able to load/save JSON objects from/to streams/files.
+ * fixed small bug in generating of unicode strings representation
+ v0.94 03/27/2007 + add properties NameOf and FieldByIndex to TlkJSONobject
+ * fix small error in parsing unicode chars
+ * small changes in hashing code (try to speed up)
+ v0.93 03/05/2007 + add overloaded functions to list and object
+ + add enum type TlkJSONtypes
+ + add functions: SelfType:TlkJSONtypes and
+ SelfTypeName: String to every TlkJSONbase child
+ * fix mistype 'IndefOfName' to 'IndexOfName'
+ * fix mistype 'IndefOfObject' to 'IndexOfObject'
+ v0.92 03/02/2007 + add some fix to TlkJSON.ParseText to fix bug with parsing
+ objects - object methods not always added properly
+ to hash array (thanx to Chris Matheson)
+ ...
+}
+
+unit uLkJSON;
+
+{$IFDEF fpc}
+ {$MODE objfpc}
+ {$H+}
+ {.$DEFINE HAVE_FORMATSETTING}
+{$ELSE}
+ {$IF RTLVersion > 14.00}
+ {$DEFINE HAVE_FORMATSETTING}
+ {$IF RTLVersion > 19.00}
+ {$DEFINE USE_D2009}
+ {$IFEND}
+ {$IFEND}
+{$ENDIF}
+
+interface
+
+{.$DEFINE USE_D2009}
+{.$DEFINE KOL}
+{.$define DOTNET}
+{$DEFINE THREADSAFE}
+{$DEFINE NEW_STYLE_GENERATE}
+{.$DEFINE USE_HASH}
+{.$DEFINE TCB_EXT}
+
+uses windows,
+ SysUtils,
+{$IFNDEF KOL}
+ classes,
+{$ELSE}
+ kol,
+{$ENDIF}
+ variants;
+
+type
+ TlkJSONtypes = (jsBase, jsNumber, jsString, jsBoolean, jsNull,
+ jsList, jsObject);
+
+{$IFDEF DOTNET}
+
+ TlkJSONdotnetclass = class
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure AfterConstruction; virtual;
+ procedure BeforeDestruction; virtual;
+ end;
+
+{$ENDIF DOTNET}
+
+ TlkJSONbase = class{$IFDEF DOTNET}(TlkJSONdotnetclass){$ENDIF}
+ protected
+ function GetValue: variant; virtual;
+ procedure SetValue(const AValue: variant); virtual;
+ function GetChild(idx: Integer): TlkJSONbase; virtual;
+ procedure SetChild(idx: Integer; const AValue: TlkJSONbase);
+ virtual;
+ function GetCount: Integer; virtual;
+ function GetField(AName: Variant):TlkJSONbase; virtual;
+ public
+ property Field[AName: Variant]: TlkJSONbase read GetField;
+ property Count: Integer read GetCount;
+ property Child[idx: Integer]: TlkJSONbase read GetChild write SetChild;
+ property Value: variant read GetValue write SetValue;
+ class function SelfType: TlkJSONtypes; virtual;
+ class function SelfTypeName: string; virtual;
+ end;
+
+ TlkJSONnumber = class(TlkJSONbase)
+ protected
+ FValue: extended;
+ function GetValue: Variant; override;
+ procedure SetValue(const AValue: Variant); override;
+ public
+ procedure AfterConstruction; override;
+ class function Generate(AValue: extended = 0): TlkJSONnumber;
+ class function SelfType: TlkJSONtypes; override;
+ class function SelfTypeName: string; override;
+ end;
+
+ TlkJSONstring = class(TlkJSONbase)
+ protected
+ FValue: WideString;
+ function GetValue: Variant; override;
+ procedure SetValue(const AValue: Variant); override;
+ public
+ procedure AfterConstruction; override;
+ class function Generate(const wsValue: WideString = ''):
+ TlkJSONstring;
+ class function SelfType: TlkJSONtypes; override;
+ class function SelfTypeName: string; override;
+ end;
+
+ TlkJSONboolean = class(TlkJSONbase)
+ protected
+ FValue: Boolean;
+ function GetValue: Variant; override;
+ procedure SetValue(const AValue: Variant); override;
+ public
+ procedure AfterConstruction; override;
+ class function Generate(AValue: Boolean = true): TlkJSONboolean;
+ class function SelfType: TlkJSONtypes; override;
+ class function SelfTypeName: string; override;
+ end;
+
+ TlkJSONnull = class(TlkJSONbase)
+ protected
+ function GetValue: Variant; override;
+ function Generate: TlkJSONnull;
+ public
+ class function SelfType: TlkJSONtypes; override;
+ class function SelfTypeName: string; override;
+ end;
+
+ TlkJSONFuncEnum = procedure(ElName: string; Elem: TlkJSONbase;
+ data: pointer; var Continue: Boolean) of object;
+
+ TlkJSONcustomlist = class(TlkJSONbase)
+ protected
+// FValue: array of TlkJSONbase;
+ fList: TList;
+ function GetCount: Integer; override;
+ function GetChild(idx: Integer): TlkJSONbase; override;
+ procedure SetChild(idx: Integer; const AValue: TlkJSONbase);
+ override;
+ function ForEachElement(idx: Integer; var nm: string):
+ TlkJSONbase; virtual;
+
+ function GetField(AName: Variant):TlkJSONbase; override;
+
+ function _Add(obj: TlkJSONbase): Integer; virtual;
+ procedure _Delete(iIndex: Integer); virtual;
+ function _IndexOf(obj: TlkJSONbase): Integer; virtual;
+ public
+ procedure ForEach(fnCallBack: TlkJSONFuncEnum; pUserData:
+ pointer);
+ procedure AfterConstruction; override;
+ procedure BeforeDestruction; override;
+
+ function getInt(idx: Integer): Integer; virtual;
+ function getString(idx: Integer): string; virtual;
+ function getWideString(idx: Integer): WideString; virtual;
+ function getDouble(idx: Integer): Double; virtual;
+ function getBoolean(idx: Integer): Boolean; virtual;
+ end;
+
+ TlkJSONlist = class(TlkJSONcustomlist)
+ protected
+ public
+ function Add(obj: TlkJSONbase): Integer; overload;
+
+ function Add(aboolean: Boolean): Integer; overload;
+ function Add(nmb: double): Integer; overload;
+ function Add(s: string): Integer; overload;
+ function Add(const ws: WideString): Integer; overload;
+ function Add(inmb: Integer): Integer; overload;
+
+ procedure Delete(idx: Integer);
+ function IndexOf(obj: TlkJSONbase): Integer;
+ class function Generate: TlkJSONlist;
+ class function SelfType: TlkJSONtypes; override;
+ class function SelfTypeName: string; override;
+ end;
+
+ TlkJSONobjectmethod = class(TlkJSONbase)
+ protected
+ FValue: TlkJSONbase;
+ FName: WideString;
+ procedure SetName(const AValue: WideString);
+ public
+ property ObjValue: TlkJSONbase read FValue;
+ procedure AfterConstruction; override;
+ procedure BeforeDestruction; override;
+ property Name: WideString read FName write SetName;
+ class function Generate(const aname: WideString; aobj: TlkJSONbase):
+ TlkJSONobjectmethod;
+ end;
+
+{$IFDEF USE_HASH}
+ PlkHashItem = ^TlkHashItem;
+ TlkHashItem = packed record
+ hash: cardinal;
+ index: Integer;
+ end;
+
+ TlkHashFunction = function(const ws: WideString): cardinal of
+ object;
+
+ TlkHashTable = class
+ private
+ FParent: TObject; // TCB:parent for check chaining op.
+ FHashFunction: TlkHashFunction;
+ procedure SetHashFunction(const AValue: TlkHashFunction);
+ protected
+ a_x: array[0..255] of TList;
+ procedure hswap(j, k, l: Integer);
+ function InTable(const ws: WideString; var i, j, k: cardinal):
+ Boolean;
+ public
+ function counters: string;
+
+ function DefaultHashOf(const ws: WideString): cardinal;
+ function SimpleHashOf(const ws: WideString): cardinal;
+
+ property HashOf: TlkHashFunction read FHashFunction write
+ SetHashFunction;
+
+ function IndexOf(const ws: WideString): Integer;
+
+ procedure AddPair(const ws: WideString; idx: Integer);
+ procedure Delete(const ws: WideString);
+
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+{$ELSE}
+
+// implementation based on "Arne Andersson, Balanced Search Trees Made Simpler"
+
+ PlkBalNode = ^TlkBalNode;
+ TlkBalNode = packed record
+ left,right: PlkBalNode;
+ level: byte;
+ key: Integer;
+ nm: WideString;
+ end;
+
+ TlkBalTree = class
+ protected
+ fdeleted,flast,fbottom,froot: PlkBalNode;
+ procedure skew(var t:PlkBalNode);
+ procedure split(var t:PlkBalNode);
+ public
+ function counters: string;
+
+ procedure Clear;
+
+ function Insert(const ws: WideString; x: Integer): Boolean;
+ function Delete(const ws: WideString): Boolean;
+
+ function IndexOf(const ws: WideString): Integer;
+
+ constructor Create;
+ destructor Destroy; override;
+ end;
+{$ENDIF USE_HASH}
+
+ TlkJSONobject = class(TlkJSONcustomlist)
+ protected
+{$IFDEF USE_HASH}
+ ht: TlkHashTable;
+{$ELSE}
+ ht: TlkBalTree;
+{$ENDIF USE_HASH}
+ FUseHash: Boolean;
+ function GetFieldByIndex(idx: Integer): TlkJSONbase;
+ function GetNameOf(idx: Integer): WideString;
+ procedure SetFieldByIndex(idx: Integer; const AValue: TlkJSONbase);
+{$IFDEF USE_HASH}
+ function GetHashTable: TlkHashTable;
+{$ELSE}
+ function GetHashTable: TlkBalTree;
+{$ENDIF USE_HASH}
+ function ForEachElement(idx: Integer; var nm: string): TlkJSONbase;
+ override;
+ function GetField(AName: Variant):TlkJSONbase; override;
+ public
+ property UseHash: Boolean read FUseHash;
+{$IFDEF USE_HASH}
+ property HashTable: TlkHashTable read GetHashTable;
+{$ELSE}
+ property HashTable: TlkBalTree read GetHashTable;
+{$ENDIF USE_HASH}
+
+ function Add(const aname: WideString; aobj: TlkJSONbase): Integer;
+ overload;
+
+ function OldGetField(nm: WideString): TlkJSONbase;
+ procedure OldSetField(nm: WideString; const AValue: TlkJSONbase);
+
+ function Add(const aname: WideString; aboolean: Boolean): Integer; overload;
+ function Add(const aname: WideString; nmb: double): Integer; overload;
+ function Add(const aname: WideString; s: string): Integer; overload;
+ function Add(const aname: WideString; const ws: WideString): Integer;
+ overload;
+ function Add(const aname: WideString; inmb: Integer): Integer; overload;
+
+ procedure Delete(idx: Integer);
+ function IndexOfName(const aname: WideString): Integer;
+ function IndexOfObject(aobj: TlkJSONbase): Integer;
+ property Field[nm: WideString]: TlkJSONbase read OldGetField
+ write OldSetField; default;
+
+ constructor Create(bUseHash: Boolean = true);
+ destructor Destroy; override;
+
+ class function Generate(AUseHash: Boolean = true): TlkJSONobject;
+ class function SelfType: TlkJSONtypes; override;
+ class function SelfTypeName: string; override;
+
+ property FieldByIndex[idx: Integer]: TlkJSONbase read GetFieldByIndex
+ write SetFieldByIndex;
+ property NameOf[idx: Integer]: WideString read GetNameOf;
+
+ function getDouble(idx: Integer): Double; overload; override;
+ function getInt(idx: Integer): Integer; overload; override;
+ function getString(idx: Integer): string; overload; override;
+ function getWideString(idx: Integer): WideString; overload; override;
+ function getBoolean(idx: Integer): Boolean; overload; override;
+
+ function {$ifdef TCB_EXT}getDoubleFromName{$else}getDouble{$endif}
+ (nm: string): Double; overload;
+ function {$ifdef TCB_EXT}getIntFromName{$else}getInt{$endif}
+ (nm: string): Integer; overload;
+ function {$ifdef TCB_EXT}getStringFromName{$else}getString{$endif}
+ (nm: string): string; overload;
+ function {$ifdef TCB_EXT}getWideStringFromName{$else}getWideString{$endif}
+ (nm: string): WideString; overload;
+ function {$ifdef TCB_EXT}getBooleanFromName{$else}getBoolean{$endif}
+ (nm: string): Boolean; overload;
+ end;
+
+ TlkJSON = class
+ public
+ class function ParseText(const txt: string): TlkJSONbase;
+ class function GenerateText(obj: TlkJSONbase): string;
+ end;
+
+{$IFNDEF KOL}
+ TlkJSONstreamed = class(TlkJSON)
+ class function LoadFromStream(src: TStream): TlkJSONbase;
+ class procedure SaveToStream(obj: TlkJSONbase; dst: TStream);
+ class function LoadFromFile(srcname: string): TlkJSONbase;
+ class procedure SaveToFile(obj: TlkJSONbase; dstname: string);
+ end;
+{$ENDIF}
+
+function GenerateReadableText(vObj: TlkJSONbase; var vLevel:
+ Integer): string;
+
+implementation
+
+uses math,strutils;
+
+type
+ ElkIntException = class(Exception)
+ public
+ idx: Integer;
+ constructor Create(idx: Integer; msg: string);
+ end;
+
+// author of next two functions is Kusnassriyanto Saiful Bahri
+
+function Indent(vTab: Integer): string;
+begin
+ result := DupeString(' ', vTab);
+end;
+
+function GenerateReadableText(vObj: TlkJSONbase; var vLevel:
+ Integer): string;
+var
+ i: Integer;
+ vStr: string;
+ xs: TlkJSONstring;
+begin
+ vLevel := vLevel + 1;
+ if vObj is TlkJSONObject then
+ begin
+ vStr := '';
+ for i := 0 to TlkJSONobject(vObj).Count - 1 do
+ begin
+ if vStr <> '' then
+ begin
+ vStr := vStr + ','#13#10;
+ end;
+ vStr := vStr + Indent(vLevel) +
+ GenerateReadableText(TlkJSONobject(vObj).Child[i], vLevel);
+ end;
+ if vStr <> '' then
+ begin
+ vStr := '{'#13#10 + vStr + #13#10 + Indent(vLevel - 1) + '}';
+ end
+ else
+ begin
+ vStr := '{}';
+ end;
+ result := vStr;
+ end
+ else if vObj is TlkJSONList then
+ begin
+ vStr := '';
+ for i := 0 to TlkJSONList(vObj).Count - 1 do
+ begin
+ if vStr <> '' then
+ begin
+ vStr := vStr + ','#13#10;
+ end;
+ vStr := vStr + Indent(vLevel) +
+ GenerateReadableText(TlkJSONList(vObj).Child[i], vLevel);
+ end;
+ if vStr <> '' then
+ begin
+ vStr := '['#13#10 + vStr + #13#10 + Indent(vLevel - 1) + ']';
+ end
+ else
+ begin
+ vStr := '[]';
+ end;
+ result := vStr;
+ end
+ else if vObj is TlkJSONobjectmethod then
+ begin
+ vStr := '';
+ xs := TlkJSONstring.Create;
+ try
+ xs.Value := TlkJSONobjectMethod(vObj).Name;
+ vStr := GenerateReadableText(xs, vLevel);
+ vLevel := vLevel - 1;
+ vStr := vStr + ':' + GenerateReadableText(TlkJSONbase(
+ TlkJSONobjectmethod(vObj).ObjValue), vLevel);
+ //vStr := vStr + ':' + GenerateReadableText(TlkJSONbase(vObj), vLevel);
+ vLevel := vLevel + 1;
+ result := vStr;
+ finally
+ xs.Free;
+ end;
+ end
+ else
+ begin
+ if vObj is TlkJSONobjectmethod then
+ begin
+ if TlkJSONobjectMethod(vObj).Name <> '' then
+ begin
+ end;
+ end;
+ result := TlkJSON.GenerateText(vObj);
+ end;
+ vLevel := vLevel - 1;
+end;
+
+// author of this routine is IVO GELOV
+
+function code2utf(iNumber: Integer): UTF8String;
+begin
+ if iNumber < 128 then Result := chr(iNumber)
+ else if iNumber < 2048 then
+ Result := chr((iNumber shr 6) + 192) + chr((iNumber and 63) + 128)
+ else if iNumber < 65536 then
+ Result := chr((iNumber shr 12) + 224) + chr(((iNumber shr 6) and
+ 63) + 128) + chr((iNumber and 63) + 128)
+ else if iNumber < 2097152 then
+ Result := chr((iNumber shr 18) + 240) + chr(((iNumber shr 12) and
+ 63) + 128) + chr(((iNumber shr 6) and 63) + 128) +
+ chr((iNumber and 63) + 128);
+end;
+
+{ TlkJSONbase }
+
+function TlkJSONbase.GetChild(idx: Integer): TlkJSONbase;
+begin
+ result := nil;
+end;
+
+function TlkJSONbase.GetCount: Integer;
+begin
+ result := 0;
+end;
+
+function TlkJSONbase.GetField(AName: Variant):TlkJSONbase;
+begin
+ result := self;
+end;
+
+function TlkJSONbase.GetValue: variant;
+begin
+ result := variants.Null;
+end;
+
+class function TlkJSONbase.SelfType: TlkJSONtypes;
+begin
+ result := jsBase;
+end;
+
+class function TlkJSONbase.SelfTypeName: string;
+begin
+ result := 'jsBase';
+end;
+
+procedure TlkJSONbase.SetChild(idx: Integer; const AValue:
+ TlkJSONbase);
+begin
+
+end;
+
+procedure TlkJSONbase.SetValue(const AValue: variant);
+begin
+
+end;
+
+{ TlkJSONnumber }
+
+procedure TlkJSONnumber.AfterConstruction;
+begin
+ inherited;
+ FValue := 0;
+end;
+
+class function TlkJSONnumber.Generate(AValue: extended):
+ TlkJSONnumber;
+begin
+ result := TlkJSONnumber.Create;
+ result.FValue := AValue;
+end;
+
+function TlkJSONnumber.GetValue: Variant;
+begin
+ result := FValue;
+end;
+
+class function TlkJSONnumber.SelfType: TlkJSONtypes;
+begin
+ result := jsNumber;
+end;
+
+class function TlkJSONnumber.SelfTypeName: string;
+begin
+ result := 'jsNumber';
+end;
+
+procedure TlkJSONnumber.SetValue(const AValue: Variant);
+begin
+ FValue := VarAsType(AValue, varDouble);
+end;
+
+{ TlkJSONstring }
+
+procedure TlkJSONstring.AfterConstruction;
+begin
+ inherited;
+ FValue := '';
+end;
+
+class function TlkJSONstring.Generate(const wsValue: WideString):
+ TlkJSONstring;
+begin
+ result := TlkJSONstring.Create;
+ result.FValue := wsValue;
+end;
+
+function TlkJSONstring.GetValue: Variant;
+begin
+ result := FValue;
+end;
+
+class function TlkJSONstring.SelfType: TlkJSONtypes;
+begin
+ result := jsString;
+end;
+
+class function TlkJSONstring.SelfTypeName: string;
+begin
+ result := 'jsString';
+end;
+
+procedure TlkJSONstring.SetValue(const AValue: Variant);
+begin
+ FValue := VarToWideStr(AValue);
+end;
+
+{ TlkJSONboolean }
+
+procedure TlkJSONboolean.AfterConstruction;
+begin
+ FValue := false;
+end;
+
+class function TlkJSONboolean.Generate(AValue: Boolean):
+ TlkJSONboolean;
+begin
+ result := TlkJSONboolean.Create;
+ result.Value := AValue;
+end;
+
+function TlkJSONboolean.GetValue: Variant;
+begin
+ result := FValue;
+end;
+
+class function TlkJSONboolean.SelfType: TlkJSONtypes;
+begin
+ Result := jsBoolean;
+end;
+
+class function TlkJSONboolean.SelfTypeName: string;
+begin
+ Result := 'jsBoolean';
+end;
+
+procedure TlkJSONboolean.SetValue(const AValue: Variant);
+begin
+ FValue := boolean(AValue);
+end;
+
+{ TlkJSONnull }
+
+function TlkJSONnull.Generate: TlkJSONnull;
+begin
+ result := TlkJSONnull.Create;
+end;
+
+function TlkJSONnull.GetValue: Variant;
+begin
+ result := variants.Null;
+end;
+
+class function TlkJSONnull.SelfType: TlkJSONtypes;
+begin
+ result := jsNull;
+end;
+
+class function TlkJSONnull.SelfTypeName: string;
+begin
+ result := 'jsNull';
+end;
+
+{ TlkJSONcustomlist }
+
+function TlkJSONcustomlist._Add(obj: TlkJSONbase): Integer;
+begin
+ if not Assigned(obj) then
+ begin
+ result := -1;
+ exit;
+ end;
+ result := fList.Add(obj);
+end;
+
+procedure TlkJSONcustomlist.AfterConstruction;
+begin
+ inherited;
+ fList := TList.Create;
+end;
+
+procedure TlkJSONcustomlist.BeforeDestruction;
+var
+ i: Integer;
+begin
+ for i := (Count - 1) downto 0 do _Delete(i);
+ fList.Free;
+ inherited;
+end;
+
+// renamed
+
+procedure TlkJSONcustomlist._Delete(iIndex: Integer);
+var
+ idx: Integer;
+begin
+ if not ((iIndex < 0) or (iIndex >= Count)) then
+ begin
+ if fList.Items[iIndex] <> nil then
+ TlkJSONbase(fList.Items[iIndex]).Free;
+ idx := pred(fList.Count);
+ if iIndex= Count) then
+ begin
+ result := nil;
+ end
+ else
+ begin
+ result := fList.Items[idx];
+ end;
+end;
+
+function TlkJSONcustomlist.GetCount: Integer;
+begin
+ result := fList.Count;
+end;
+
+function TlkJSONcustomlist._IndexOf(obj: TlkJSONbase): Integer;
+begin
+ result := fList.IndexOf(obj);
+end;
+
+procedure TlkJSONcustomlist.SetChild(idx: Integer; const AValue:
+ TlkJSONbase);
+begin
+ if not ((idx < 0) or (idx >= Count)) then
+ begin
+ if fList.Items[idx] <> nil then
+ TlkJSONbase(fList.Items[idx]).Free;
+ fList.Items[idx] := AValue;
+ end;
+end;
+
+procedure TlkJSONcustomlist.ForEach(fnCallBack: TlkJSONFuncEnum;
+ pUserData:
+ pointer);
+var
+ iCount: Integer;
+ IsContinue: Boolean;
+ anJSON: TlkJSONbase;
+ wsObject: string;
+begin
+ if not assigned(fnCallBack) then exit;
+ IsContinue := true;
+ for iCount := 0 to GetCount - 1 do
+ begin
+ anJSON := ForEachElement(iCount, wsObject);
+ if assigned(anJSON) then
+ fnCallBack(wsObject, anJSON, pUserData, IsContinue);
+ if not IsContinue then break;
+ end;
+end;
+
+///---- renamed to here
+
+function TlkJSONcustomlist.GetField(AName: Variant):TlkJSONbase;
+var
+ index: Integer;
+begin
+ if VarIsNumeric(AName) then
+ begin
+ index := integer(AName);
+ result := GetChild(index);
+ end
+ else
+ begin
+ result := inherited GetField(AName);
+ end;
+end;
+
+function TlkJSONcustomlist.ForEachElement(idx: Integer; var nm:
+ string): TlkJSONbase;
+begin
+ nm := inttostr(idx);
+ result := GetChild(idx);
+end;
+
+function TlkJSONcustomlist.getDouble(idx: Integer): Double;
+var
+ jn: TlkJSONnumber;
+begin
+ jn := Child[idx] as TlkJSONnumber;
+ if not assigned(jn) then result := 0
+ else result := jn.Value;
+end;
+
+function TlkJSONcustomlist.getInt(idx: Integer): Integer;
+var
+ jn: TlkJSONnumber;
+begin
+ jn := Child[idx] as TlkJSONnumber;
+ if not assigned(jn) then result := 0
+ else result := round(int(jn.Value));
+end;
+
+function TlkJSONcustomlist.getString(idx: Integer): string;
+var
+ js: TlkJSONstring;
+begin
+ js := Child[idx] as TlkJSONstring;
+ if not assigned(js) then result := ''
+ else result := VarToStr(js.Value);
+end;
+
+function TlkJSONcustomlist.getWideString(idx: Integer): WideString;
+var
+ js: TlkJSONstring;
+begin
+ js := Child[idx] as TlkJSONstring;
+ if not assigned(js) then result := ''
+ else result := VarToWideStr(js.Value);
+end;
+
+function TlkJSONcustomlist.getBoolean(idx: Integer): Boolean;
+var
+ jb: TlkJSONboolean;
+begin
+ jb := Child[idx] as TlkJSONboolean;
+ if not assigned(jb) then result := false
+ else result := jb.Value;
+end;
+
+{ TlkJSONobjectmethod }
+
+procedure TlkJSONobjectmethod.AfterConstruction;
+begin
+ inherited;
+ FValue := nil;
+ FName := '';
+end;
+
+procedure TlkJSONobjectmethod.BeforeDestruction;
+begin
+ FName := '';
+ if FValue <> nil then
+ begin
+ FValue.Free;
+ FValue := nil;
+ end;
+ inherited;
+end;
+
+class function TlkJSONobjectmethod.Generate(const aname: WideString;
+ aobj: TlkJSONbase): TlkJSONobjectmethod;
+begin
+ result := TlkJSONobjectmethod.Create;
+ result.FName := aname;
+ result.FValue := aobj;
+end;
+
+procedure TlkJSONobjectmethod.SetName(const AValue: WideString);
+begin
+ FName := AValue;
+end;
+
+{ TlkJSONlist }
+
+function TlkJSONlist.Add(obj: TlkJSONbase): Integer;
+begin
+ result := _Add(obj);
+end;
+
+function TlkJSONlist.Add(nmb: double): Integer;
+begin
+ Result := self.Add(TlkJSONnumber.Generate(nmb));
+end;
+
+function TlkJSONlist.Add(aboolean: Boolean): Integer;
+begin
+ Result := self.Add(TlkJSONboolean.Generate(aboolean));
+end;
+
+function TlkJSONlist.Add(inmb: Integer): Integer;
+begin
+ Result := self.Add(TlkJSONnumber.Generate(inmb));
+end;
+
+function TlkJSONlist.Add(const ws: WideString): Integer;
+begin
+ Result := self.Add(TlkJSONstring.Generate(ws));
+end;
+
+function TlkJSONlist.Add(s: string): Integer;
+begin
+ Result := self.Add(TlkJSONstring.Generate(s));
+end;
+
+procedure TlkJSONlist.Delete(idx: Integer);
+begin
+ _Delete(idx);
+end;
+
+class function TlkJSONlist.Generate: TlkJSONlist;
+begin
+ result := TlkJSONlist.Create;
+end;
+
+function TlkJSONlist.IndexOf(obj: TlkJSONbase): Integer;
+begin
+ result := _IndexOf(obj);
+end;
+
+class function TlkJSONlist.SelfType: TlkJSONtypes;
+begin
+ result := jsList;
+end;
+
+class function TlkJSONlist.SelfTypeName: string;
+begin
+ result := 'jsList';
+end;
+
+{ TlkJSONobject }
+
+function TlkJSONobject.Add(const aname: WideString; aobj:
+ TlkJSONbase):
+ Integer;
+var
+ mth: TlkJSONobjectmethod;
+begin
+ if not assigned(aobj) then
+ begin
+ result := -1;
+ exit;
+ end;
+ mth := TlkJSONobjectmethod.Create;
+ mth.FName := aname;
+ mth.FValue := aobj;
+ result := self._Add(mth);
+ if FUseHash then
+{$IFDEF USE_HASH}
+ ht.AddPair(aname, result);
+{$ELSE}
+ ht.Insert(aname, result);
+{$ENDIF USE_HASH}
+end;
+
+procedure TlkJSONobject.Delete(idx: Integer);
+var
+ i,j,k:cardinal;
+ mth: TlkJSONobjectmethod;
+begin
+ if (idx >= 0) and (idx < Count) then
+ begin
+// mth := FValue[idx] as TlkJSONobjectmethod;
+ mth := TlkJSONobjectmethod(fList.Items[idx]);
+ if FUseHash then
+ begin
+ ht.Delete(mth.FName);
+ end;
+ end;
+ _Delete(idx);
+{$ifdef USE_HASH}
+ if (idx -1 then
+ begin
+// mth := TlkJSONobjectmethod(FValue[i]);
+ mth := TlkJSONobjectmethod(fList.Items[i]);
+ mth.FValue := AValue;
+ end;
+end;
+
+function TlkJSONobject.Add(const aname: WideString; nmb: double):
+ Integer;
+begin
+ Result := self.Add(aname, TlkJSONnumber.Generate(nmb));
+end;
+
+function TlkJSONobject.Add(const aname: WideString; aboolean: Boolean):
+ Integer;
+begin
+ Result := self.Add(aname, TlkJSONboolean.Generate(aboolean));
+end;
+
+function TlkJSONobject.Add(const aname: WideString; s: string):
+ Integer;
+begin
+ Result := self.Add(aname, TlkJSONstring.Generate(s));
+end;
+
+function TlkJSONobject.Add(const aname: WideString; inmb: Integer):
+ Integer;
+begin
+ Result := self.Add(aname, TlkJSONnumber.Generate(inmb));
+end;
+
+function TlkJSONobject.Add(const aname, ws: WideString): Integer;
+begin
+ Result := self.Add(aname, TlkJSONstring.Generate(ws));
+end;
+
+class function TlkJSONobject.SelfType: TlkJSONtypes;
+begin
+ Result := jsObject;
+end;
+
+class function TlkJSONobject.SelfTypeName: string;
+begin
+ Result := 'jsObject';
+end;
+
+function TlkJSONobject.GetFieldByIndex(idx: Integer): TlkJSONbase;
+var
+ nm: WideString;
+begin
+ nm := GetNameOf(idx);
+ if nm <> '' then
+ begin
+ result := Field[nm];
+ end
+ else
+ begin
+ result := nil;
+ end;
+end;
+
+function TlkJSONobject.GetNameOf(idx: Integer): WideString;
+var
+ mth: TlkJSONobjectmethod;
+begin
+ if (idx < 0) or (idx >= Count) then
+ begin
+ result := '';
+ end
+ else
+ begin
+ mth := Child[idx] as TlkJSONobjectmethod;
+ result := mth.Name;
+ end;
+end;
+
+procedure TlkJSONobject.SetFieldByIndex(idx: Integer;
+ const AValue: TlkJSONbase);
+var
+ nm: WideString;
+begin
+ nm := GetNameOf(idx);
+ if nm <> '' then
+ begin
+ Field[nm] := AValue;
+ end;
+end;
+
+function TlkJSONobject.ForEachElement(idx: Integer;
+ var nm: string): TlkJSONbase;
+begin
+ nm := GetNameOf(idx);
+ result := GetFieldByIndex(idx);
+end;
+
+function TlkJSONobject.GetField(AName: Variant):TlkJSONbase;
+begin
+ if VarIsStr(AName) then
+ result := OldGetField(VarToWideStr(AName))
+ else
+ result := inherited GetField(AName);
+end;
+
+{$IFDEF USE_HASH}
+function TlkJSONobject.GetHashTable: TlkHashTable;
+{$ELSE}
+function TlkJSONobject.GetHashTable: TlkBalTree;
+{$ENDIF USE_HASH}
+begin
+ result := ht;
+end;
+
+constructor TlkJSONobject.Create(bUseHash: Boolean);
+begin
+ inherited Create;
+ FUseHash := bUseHash;
+{$IFDEF USE_HASH}
+ ht := TlkHashTable.Create;
+ ht.FParent := self;
+{$ELSE}
+ ht := TlkBalTree.Create;
+{$ENDIF}
+end;
+
+destructor TlkJSONobject.Destroy;
+begin
+ if assigned(ht) then FreeAndNil(ht);
+ inherited;
+end;
+
+function TlkJSONobject.getDouble(idx: Integer): Double;
+var
+ jn: TlkJSONnumber;
+begin
+ jn := FieldByIndex[idx] as TlkJSONnumber;
+ if not assigned(jn) then result := 0
+ else result := jn.Value;
+end;
+
+function TlkJSONobject.getInt(idx: Integer): Integer;
+var
+ jn: TlkJSONnumber;
+begin
+ jn := FieldByIndex[idx] as TlkJSONnumber;
+ if not assigned(jn) then result := 0
+ else result := round(int(jn.Value));
+end;
+
+function TlkJSONobject.getString(idx: Integer): string;
+var
+ js: TlkJSONstring;
+begin
+ js := FieldByIndex[idx] as TlkJSONstring;
+ if not assigned(js) then result := ''
+ else result := vartostr(js.Value);
+end;
+
+function TlkJSONobject.getWideString(idx: Integer): WideString;
+var
+ js: TlkJSONstring;
+begin
+ js := FieldByIndex[idx] as TlkJSONstring;
+ if not assigned(js) then result := ''
+ else result := VarToWideStr(js.Value);
+end;
+
+{$ifdef TCB_EXT}
+function TlkJSONobject.getDoubleFromName(nm: string): Double;
+{$else}
+function TlkJSONobject.getDouble(nm: string): Double;
+{$endif}
+begin
+ result := getDouble(IndexOfName(nm));
+end;
+
+{$ifdef TCB_EXT}
+function TlkJSONobject.getIntFromName(nm: string): Integer;
+{$else}
+function TlkJSONobject.getInt(nm: string): Integer;
+{$endif}
+begin
+ result := getInt(IndexOfName(nm));
+end;
+
+{$ifdef TCB_EXT}
+function TlkJSONobject.getStringFromName(nm: string): string;
+{$else}
+function TlkJSONobject.getString(nm: string): string;
+{$endif}
+begin
+ result := getString(IndexOfName(nm));
+end;
+
+{$ifdef TCB_EXT}
+function TlkJSONobject.getWideStringFromName(nm: string): WideString;
+{$else}
+function TlkJSONobject.getWideString(nm: string): WideString;
+{$endif}
+begin
+ result := getWideString(IndexOfName(nm));
+end;
+
+function TlkJSONobject.getBoolean(idx: Integer): Boolean;
+var
+ jb: TlkJSONboolean;
+begin
+ jb := FieldByIndex[idx] as TlkJSONboolean;
+ if not assigned(jb) then result := false
+ else result := jb.Value;
+end;
+
+{$ifdef TCB_EXT}
+function TlkJSONobject.getBooleanFromName(nm: string): Boolean;
+{$else}
+function TlkJSONobject.getBoolean(nm: string): Boolean;
+{$endif}
+begin
+ result := getBoolean(IndexOfName(nm));
+end;
+
+{ TlkJSON }
+
+class function TlkJSON.GenerateText(obj: TlkJSONbase): string;
+var
+{$IFDEF HAVE_FORMATSETTING}
+ fs: TFormatSettings;
+{$ENDIF}
+ pt1, pt0, pt2: PChar;
+ ptsz: cardinal;
+
+{$IFNDEF NEW_STYLE_GENERATE}
+
+ function gn_base(obj: TlkJSONbase): string;
+ var
+ ws: string;
+ i, j: Integer;
+ xs: TlkJSONstring;
+ begin
+ result := '';
+ if not assigned(obj) then exit;
+ if obj is TlkJSONnumber then
+ begin
+{$IFDEF HAVE_FORMATSETTING}
+ result := FloatToStr(TlkJSONnumber(obj).FValue, fs);
+{$ELSE}
+ result := FloatToStr(TlkJSONnumber(obj).FValue);
+ i := pos(DecimalSeparator, result);
+ if (DecimalSeparator <> '.') and (i > 0) then
+ result[i] := '.';
+{$ENDIF}
+ end
+ else if obj is TlkJSONstring then
+ begin
+ ws := UTF8Encode(TlkJSONstring(obj).FValue);
+ i := 1;
+ result := '"';
+ while i <= length(ws) do
+ begin
+ case ws[i] of
+ '/', '\', '"': result := result + '\' + ws[i];
+ #8: result := result + '\b';
+ #9: result := result + '\t';
+ #10: result := result + '\n';
+ #13: result := result + '\r';
+ #12: result := result + '\f';
+ else
+ if ord(ws[i]) < 32 then
+ result := result + '\u' + inttohex(ord(ws[i]), 4)
+ else
+ result := result + ws[i];
+ end;
+ inc(i);
+ end;
+ result := result + '"';
+ end
+ else if obj is TlkJSONboolean then
+ begin
+ if TlkJSONboolean(obj).FValue then
+ result := 'true'
+ else
+ result := 'false';
+ end
+ else if obj is TlkJSONnull then
+ begin
+ result := 'null';
+ end
+ else if obj is TlkJSONlist then
+ begin
+ result := '[';
+ j := TlkJSONobject(obj).Count - 1;
+ for i := 0 to j do
+ begin
+ if i > 0 then result := result + ',';
+ result := result + gn_base(TlkJSONlist(obj).Child[i]);
+ end;
+ result := result + ']';
+ end
+ else if obj is TlkJSONobjectmethod then
+ begin
+ try
+ xs := TlkJSONstring.Create;
+ xs.FValue := TlkJSONobjectmethod(obj).FName;
+ result := gn_base(TlkJSONbase(xs)) + ':';
+ result := result +
+ gn_base(TlkJSONbase(TlkJSONobjectmethod(obj).FValue));
+ finally
+ if assigned(xs) then FreeAndNil(xs);
+ end;
+ end
+ else if obj is TlkJSONobject then
+ begin
+ result := '{';
+ j := TlkJSONobject(obj).Count - 1;
+ for i := 0 to j do
+ begin
+ if i > 0 then result := result + ',';
+ result := result + gn_base(TlkJSONobject(obj).Child[i]);
+ end;
+ result := result + '}';
+ end;
+ end;
+{$ELSE}
+
+ procedure get_more_memory;
+ var
+ delta: cardinal;
+ begin
+ delta := 50000;
+ if pt0 = nil then
+ begin
+ pt0 := AllocMem(delta);
+ ptsz := 0;
+ pt1 := pt0;
+ end
+ else
+ begin
+ ReallocMem(pt0, ptsz + delta);
+ pt1 := pointer(cardinal(pt0) + ptsz);
+ end;
+ ptsz := ptsz + delta;
+ pt2 := pointer(cardinal(pt1) + delta);
+ end;
+
+ procedure mem_ch(ch: char);
+ begin
+ if pt1 >= pt2 then get_more_memory;
+ pt1^ := ch;
+ inc(pt1);
+ end;
+
+ procedure mem_write(rs: string);
+ var
+ i: Integer;
+ begin
+ for i := 1 to length(rs) do
+ begin
+ if pt1 >= pt2 then get_more_memory;
+ pt1^ := rs[i];
+ inc(pt1);
+ end;
+ end;
+
+ procedure gn_base(obj: TlkJSONbase);
+ var
+ ws: string;
+ i, j: Integer;
+ xs: TlkJSONstring;
+ begin
+ if not assigned(obj) then exit;
+ if obj is TlkJSONnumber then
+ begin
+{$IFDEF HAVE_FORMATSETTING}
+ mem_write(FloatToStr(TlkJSONnumber(obj).FValue, fs));
+{$ELSE}
+ ws := FloatToStr(TlkJSONnumber(obj).FValue);
+ i := pos(DecimalSeparator, ws);
+ if (DecimalSeparator <> '.') and (i > 0) then ws[i] := '.';
+ mem_write(ws);
+{$ENDIF}
+ end
+ else if obj is TlkJSONstring then
+ begin
+ ws := UTF8Encode(TlkJSONstring(obj).FValue);
+ i := 1;
+ mem_ch('"');
+ while i <= length(ws) do
+ begin
+ case ws[i] of
+ '/', '\', '"':
+ begin
+ mem_ch('\');
+ mem_ch(ws[i]);
+ end;
+ #8: mem_write('\b');
+ #9: mem_write('\t');
+ #10: mem_write('\n');
+ #13: mem_write('\r');
+ #12: mem_write('\f');
+ else
+ if ord(ws[i]) < 32 then
+ mem_write('\u' + inttohex(ord(ws[i]), 4))
+ else
+ mem_ch(ws[i]);
+ end;
+ inc(i);
+ end;
+ mem_ch('"');
+ end
+ else if obj is TlkJSONboolean then
+ begin
+ if TlkJSONboolean(obj).FValue then
+ mem_write('true')
+ else
+ mem_write('false');
+ end
+ else if obj is TlkJSONnull then
+ begin
+ mem_write('null');
+ end
+ else if obj is TlkJSONlist then
+ begin
+ mem_ch('[');
+ j := TlkJSONobject(obj).Count - 1;
+ for i := 0 to j do
+ begin
+ if i > 0 then mem_ch(',');
+ gn_base(TlkJSONlist(obj).Child[i]);
+ end;
+ mem_ch(']');
+ end
+ else if obj is TlkJSONobjectmethod then
+ begin
+ try
+ xs := TlkJSONstring.Create;
+ xs.FValue := TlkJSONobjectmethod(obj).FName;
+ gn_base(TlkJSONbase(xs));
+ mem_ch(':');
+ gn_base(TlkJSONbase(TlkJSONobjectmethod(obj).FValue));
+ finally
+ if assigned(xs) then FreeAndNil(xs);
+ end;
+ end
+ else if obj is TlkJSONobject then
+ begin
+ mem_ch('{');
+ j := TlkJSONobject(obj).Count - 1;
+ for i := 0 to j do
+ begin
+ if i > 0 then mem_ch(',');
+ gn_base(TlkJSONobject(obj).Child[i]);
+ end;
+ mem_ch('}');
+ end;
+ end;
+{$ENDIF NEW_STYLE_GENERATE}
+
+begin
+{$IFDEF HAVE_FORMATSETTING}
+ GetLocaleFormatSettings(GetThreadLocale, fs);
+ fs.DecimalSeparator := '.';
+{$ENDIF}
+{$IFDEF NEW_STYLE_GENERATE}
+ pt0 := nil;
+ get_more_memory;
+ gn_base(obj);
+ mem_ch(#0);
+ result := string(pt0);
+ freemem(pt0);
+{$ELSE}
+ result := gn_base(obj);
+{$ENDIF}
+end;
+
+class function TlkJSON.ParseText(const txt: string): TlkJSONbase;
+{$IFDEF HAVE_FORMATSETTING}
+var
+ fs: TFormatSettings;
+{$ENDIF}
+
+ function js_base(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean; forward;
+
+ function xe(idx: Integer): Boolean;
+ {$IFDEF FPC}inline;
+ {$ENDIF}
+ begin
+ result := idx <= length(txt);
+ end;
+
+ procedure skip_spc(var idx: Integer);
+ {$IFDEF FPC}inline;
+ {$ENDIF}
+ begin
+ while (xe(idx)) and (ord(txt[idx]) < 33) do
+ inc(idx);
+ end;
+
+ procedure add_child(var o, c: TlkJSONbase);
+ var
+ i: Integer;
+ begin
+ if o = nil then
+ begin
+ o := c;
+ end
+ else
+ begin
+ if o is TlkJSONobjectmethod then
+ begin
+ TlkJSONobjectmethod(o).FValue := c;
+ end
+ else if o is TlkJSONlist then
+ begin
+ TlkJSONlist(o)._Add(c);
+ end
+ else if o is TlkJSONobject then
+ begin
+ i := TlkJSONobject(o)._Add(c);
+ if TlkJSONobject(o).UseHash then
+{$IFDEF USE_HASH}
+ TlkJSONobject(o).ht.AddPair(TlkJSONobjectmethod(c).Name, i);
+{$ELSE}
+ TlkJSONobject(o).ht.Insert(TlkJSONobjectmethod(c).Name, i);
+{$ENDIF USE_HASH}
+ end;
+ end;
+ end;
+
+ function js_boolean(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+ var
+ js: TlkJSONboolean;
+ begin
+ skip_spc(idx);
+ if copy(txt, idx, 4) = 'true' then
+ begin
+ result := true;
+ ridx := idx + 4;
+ js := TlkJSONboolean.Create;
+ js.FValue := true;
+ add_child(o, TlkJSONbase(js));
+ end
+ else if copy(txt, idx, 5) = 'false' then
+ begin
+ result := true;
+ ridx := idx + 5;
+ js := TlkJSONboolean.Create;
+ js.FValue := false;
+ add_child(o, TlkJSONbase(js));
+ end
+ else
+ begin
+ result := false;
+ end;
+ end;
+
+ function js_null(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+ var
+ js: TlkJSONnull;
+ begin
+ skip_spc(idx);
+ if copy(txt, idx, 4) = 'null' then
+ begin
+ result := true;
+ ridx := idx + 4;
+ js := TlkJSONnull.Create;
+ add_child(o, TlkJSONbase(js));
+ end
+ else
+ begin
+ result := false;
+ end;
+ end;
+
+ function js_integer(idx: Integer; var ridx: Integer): Boolean;
+ begin
+ result := false;
+ while (xe(idx)) and (txt[idx] in ['0'..'9']) do
+ begin
+ result := true;
+ inc(idx);
+ end;
+ if result then ridx := idx;
+ end;
+
+ function js_number(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+ var
+ js: TlkJSONnumber;
+ ws: string;
+ {$IFNDEF HAVE_FORMATSETTING}
+ i: Integer;
+ {$ENDIF}
+ begin
+ skip_spc(idx);
+ result := xe(idx);
+ if not result then exit;
+ if txt[idx] in ['+', '-'] then
+ begin
+ inc(idx);
+ result := xe(idx);
+ end;
+ if not result then exit;
+ result := js_integer(idx, idx);
+ if not result then exit;
+ if (xe(idx)) and (txt[idx] = '.') then
+ begin
+ inc(idx);
+ result := js_integer(idx, idx);
+ if not result then exit;
+ end;
+ if (xe(idx)) and (txt[idx] in ['e', 'E']) then
+ begin
+ inc(idx);
+ if (xe(idx)) and (txt[idx] in ['+', '-']) then inc(idx);
+ result := js_integer(idx, idx);
+ if not result then exit;
+ end;
+ if not result then exit;
+ js := TlkJSONnumber.Create;
+ ws := copy(txt, ridx, idx - ridx);
+{$IFDEF HAVE_FORMATSETTING}
+ js.FValue := StrToFloat(ws, fs);
+{$ELSE}
+ i := pos('.', ws);
+ if (DecimalSeparator <> '.') and (i > 0) then
+ ws[pos('.', ws)] := DecimalSeparator;
+ js.FValue := StrToFloat(ws);
+{$ENDIF}
+ add_child(o, TlkJSONbase(js));
+ ridx := idx;
+ end;
+
+{
+
+}
+ function js_string(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+
+ function strSpecialChars(const s: string): string;
+ var
+ i, j : integer;
+ begin
+ i := Pos('\', s);
+ if (i = 0) then
+ Result := s
+ else
+ begin
+ Result := Copy(s, 1, i-1);
+ j := i;
+ repeat
+ if (s[j] = '\') then
+ begin
+ inc(j);
+ case s[j] of
+ '\': Result := Result + '\';
+ '"': Result := Result + '"';
+ '''': Result := Result + '''';
+ '/': Result := Result + '/';
+ 'b': Result := Result + #8;
+ 'f': Result := Result + #12;
+ 'n': Result := Result + #10;
+ 'r': Result := Result + #13;
+ 't': Result := Result + #9;
+ 'u':
+ begin
+ Result := Result + code2utf(strtoint('$' + copy(s, j + 1, 4)));
+ inc(j, 4);
+ end;
+ end;
+ end
+ else
+ Result := Result + s[j];
+ inc(j);
+ until j > length(s);
+ end;
+ end;
+
+ var
+ js: TlkJSONstring;
+ fin: Boolean;
+ ws: String;
+ i,j,widx: Integer;
+ begin
+ skip_spc(idx);
+
+ result := xe(idx) and (txt[idx] = '"');
+ if not result then exit;
+
+ inc(idx);
+ widx := idx;
+
+ fin:=false;
+ REPEAT
+ i := 0;
+ j := 0;
+ while (widx<=length(txt)) and (j=0) do
+ begin
+ if (i=0) and (txt[widx]='\') then i:=widx;
+ if (j=0) and (txt[widx]='"') then j:=widx;
+ inc(widx);
+ end;
+// incorrect string!!!
+ if j=0 then
+ begin
+ result := false;
+ exit;
+ end;
+// if we have no slashed chars in string
+ if (i=0) or (j0 and j>=i - skip slashed char
+ else
+ begin
+ widx:=i+2;
+ end;
+ UNTIL fin;
+
+ ws := strSpecialChars(ws);
+ inc(idx);
+
+ js := TlkJSONstring.Create;
+{$ifdef USE_D2009}
+ js.FValue := UTF8ToString(ws);
+{$else}
+ js.FValue := UTF8Decode(ws);
+{$endif}
+ add_child(o, TlkJSONbase(js));
+ ridx := idx;
+ end;
+
+ function js_list(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+ var
+ js: TlkJSONlist;
+ begin
+ result := false;
+ try
+ js := TlkJSONlist.Create;
+ skip_spc(idx);
+ result := xe(idx);
+ if not result then exit;
+ result := txt[idx] = '[';
+ if not result then exit;
+ inc(idx);
+ while js_base(idx, idx, TlkJSONbase(js)) do
+ begin
+ skip_spc(idx);
+ if (xe(idx)) and (txt[idx] = ',') then inc(idx);
+ end;
+ skip_spc(idx);
+ result := (xe(idx)) and (txt[idx] = ']');
+ if not result then exit;
+ inc(idx);
+ finally
+ if not result then
+ begin
+ js.Free;
+ end
+ else
+ begin
+ add_child(o, TlkJSONbase(js));
+ ridx := idx;
+ end;
+ end;
+ end;
+
+ function js_method(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+ var
+ mth: TlkJSONobjectmethod;
+ ws: TlkJSONstring;
+ begin
+ result := false;
+ try
+ ws := nil;
+ mth := TlkJSONobjectmethod.Create;
+ skip_spc(idx);
+ result := xe(idx);
+ if not result then exit;
+ result := js_string(idx, idx, TlkJSONbase(ws));
+ if not result then exit;
+ skip_spc(idx);
+ result := xe(idx) and (txt[idx] = ':');
+ if not result then exit;
+ inc(idx);
+ mth.FName := ws.FValue;
+ result := js_base(idx, idx, TlkJSONbase(mth));
+ finally
+ if ws <> nil then ws.Free;
+ if result then
+ begin
+ add_child(o, TlkJSONbase(mth));
+ ridx := idx;
+ end
+ else
+ begin
+ mth.Free;
+ end;
+ end;
+ end;
+
+ function js_object(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+ var
+ js: TlkJSONobject;
+ begin
+ result := false;
+ try
+ js := TlkJSONobject.Create;
+ skip_spc(idx);
+ result := xe(idx);
+ if not result then exit;
+ result := txt[idx] = '{';
+ if not result then exit;
+ inc(idx);
+ while js_method(idx, idx, TlkJSONbase(js)) do
+ begin
+ skip_spc(idx);
+ if (xe(idx)) and (txt[idx] = ',') then inc(idx);
+ end;
+ skip_spc(idx);
+ result := (xe(idx)) and (txt[idx] = '}');
+ if not result then exit;
+ inc(idx);
+ finally
+ if not result then
+ begin
+ js.Free;
+ end
+ else
+ begin
+ add_child(o, TlkJSONbase(js));
+ ridx := idx;
+ end;
+ end;
+ end;
+
+ function js_base(idx: Integer; var ridx: Integer; var o:
+ TlkJSONbase): Boolean;
+ begin
+ skip_spc(idx);
+ result := js_boolean(idx, idx, o);
+ if not result then result := js_null(idx, idx, o);
+ if not result then result := js_number(idx, idx, o);
+ if not result then result := js_string(idx, idx, o);
+ if not result then result := js_list(idx, idx, o);
+ if not result then result := js_object(idx, idx, o);
+ if result then ridx := idx;
+ end;
+
+var
+ idx: Integer;
+begin
+{$IFDEF HAVE_FORMATSETTING}
+ GetLocaleFormatSettings(GetThreadLocale, fs);
+ fs.DecimalSeparator := '.';
+{$ENDIF}
+
+ result := nil;
+ if txt = '' then exit;
+ try
+ idx := 1;
+ // skip a BOM utf8 marker
+ if copy(txt,idx,3)=#239#187#191 then
+ begin
+ inc(idx,3);
+ // if there are only a BOM - exit;
+ if idx>length(txt) then exit;
+ end;
+ if not js_base(idx, idx, result) then FreeAndNil(result);
+ except
+ if assigned(result) then FreeAndNil(result);
+ end;
+end;
+
+{ ElkIntException }
+
+constructor ElkIntException.Create(idx: Integer; msg: string);
+begin
+ self.idx := idx;
+ inherited Create(msg);
+end;
+
+{ TlkHashTable }
+
+{$IFDEF USE_HASH}
+procedure TlkHashTable.AddPair(const ws: WideString; idx: Integer);
+var
+ i, j, k: cardinal;
+ p: PlkHashItem;
+ find: boolean;
+begin
+ find := false;
+ if InTable(ws, i, j, k) then
+ begin
+// if string is already in table, changing index
+ if TlkJSONobject(FParent).GetNameOf(PlkHashItem(a_x[j].Items[k])^.index) = ws then
+ begin
+ PlkHashItem(a_x[j].Items[k])^.index := idx;
+ find := true;
+ end;
+ end;
+ if find = false then
+ begin
+ GetMem(p,sizeof(TlkHashItem));
+ k := a_x[j].Add(p);
+ p^.hash := i;
+ p^.index := idx;
+ while (k>0) and (PlkHashItem(a_x[j].Items[k])^.hash < PlkHashItem(a_x[j].Items[k-1])^.hash) do
+ begin
+ a_x[j].Exchange(k,k-1);
+ dec(k);
+ end;
+ end;
+end;
+
+function TlkHashTable.counters: string;
+var
+ i, j: Integer;
+ ws: string;
+begin
+ ws := '';
+ for i := 0 to 15 do
+ begin
+ for j := 0 to 15 do
+// ws := ws + format('%.3d ', [length(a_h[i * 16 + j])]);
+ ws := ws + format('%.3d ', [a_x[i * 16 + j].Count]);
+ ws := ws + #13#10;
+ end;
+ result := ws;
+end;
+
+procedure TlkHashTable.Delete(const ws: WideString);
+var
+ i, j, k: cardinal;
+begin
+ if InTable(ws, i, j, k) then
+ begin
+// while k < high(a_h[j]) do
+// begin
+// hswap(j, k, k + 1);
+// inc(k);
+// end;
+// SetLength(a_h[j], k);
+ FreeMem(a_x[j].Items[k]);
+ a_x[j].Delete(k);
+ end;
+end;
+
+{$IFDEF THREADSAFE}
+const
+ rnd_table: array[0..255] of byte =
+ (216, 191, 234, 201, 12, 163, 190, 205, 128, 199, 210, 17, 52, 43,
+ 38, 149, 40, 207, 186, 89, 92, 179, 142, 93, 208, 215, 162,
+ 161, 132, 59, 246, 37, 120, 223, 138, 233, 172, 195, 94, 237, 32,
+ 231, 114, 49, 212, 75, 198, 181, 200, 239, 90, 121, 252, 211,
+ 46, 125, 112, 247, 66, 193, 36, 91, 150, 69, 24, 255, 42, 9, 76,
+ 227, 254, 13, 192, 7, 18, 81, 116, 107, 102, 213, 104, 15, 250,
+ 153, 156, 243, 206, 157, 16, 23, 226, 225, 196, 123, 54, 101,
+ 184, 31, 202, 41, 236, 3, 158, 45, 96, 39, 178, 113, 20, 139, 6,
+ 245, 8, 47, 154, 185, 60, 19, 110, 189, 176, 55, 130, 1, 100,
+ 155, 214, 133, 88, 63, 106, 73, 140, 35, 62, 77, 0, 71, 82, 145,
+ 180,
+ 171, 166, 21, 168, 79, 58, 217, 220, 51, 14, 221, 80, 87, 34, 33,
+ 4, 187, 118, 165, 248, 95, 10, 105, 44, 67, 222, 109, 160, 103,
+ 242, 177, 84, 203, 70, 53, 72, 111, 218, 249, 124, 83, 174, 253,
+ 240, 119, 194, 65, 164, 219, 22, 197, 152, 127, 170, 137, 204,
+ 99, 126, 141, 64, 135, 146, 209, 244, 235, 230, 85, 232, 143,
+ 122, 25, 28, 115, 78, 29, 144, 151, 98, 97, 68, 251, 182, 229,
+ 56,
+ 159, 74, 169, 108, 131, 30, 173, 224, 167, 50, 241, 148, 11, 134,
+ 117, 136, 175, 26, 57, 188, 147, 238, 61, 48, 183, 2, 129,
+ 228, 27, 86, 5);
+{$ELSE}
+var
+ rnd_table: array[0..255] of byte;
+{$ENDIF}
+
+function TlkHashTable.DefaultHashOf(const ws: WideString): cardinal;
+{$IFDEF DOTNET}
+var
+ i, j: Integer;
+ x1, x2, x3, x4: byte;
+begin
+ result := 0;
+// result := 0;
+ x1 := 0;
+ x2 := 1;
+ for i := 1 to length(ws) do
+ begin
+ j := ord(ws[i]);
+// first version of hashing
+ x1 := (x1 + j) {and $FF};
+ x2 := (x2 + 1 + (j shr 8)) {and $FF};
+ x3 := rnd_table[x1];
+ x4 := rnd_table[x3];
+ result := ((x1 * x4) + (x2 * x3)) xor result;
+ end;
+end;
+{$ELSE}
+var
+ x1, x2, x3, x4: byte;
+ p: PWideChar;
+begin
+ result := 0;
+ x1 := 0;
+ x2 := 1;
+ p := PWideChar(ws);
+ while p^ <> #0 do
+ begin
+ inc(x1, ord(p^)) {and $FF};
+ inc(x2, 1 + (ord(p^) shr 8)) {and $FF};
+ x3 := rnd_table[x1];
+ x4 := rnd_table[x3];
+ result := ((x1 * x4) + (x2 * x3)) xor result;
+ inc(p);
+ end;
+end;
+{$ENDIF}
+
+procedure TlkHashTable.hswap(j, k, l: Integer);
+//var
+// h: TlkHashItem;
+begin
+// h := a_h[j, k];
+// a_h[j, k] := a_h[j, l];
+// a_h[j, l] := h;
+ a_x[j].Exchange(k, l);
+end;
+
+function TlkHashTable.IndexOf(const ws: WideString): Integer;
+var
+ i, j, k: Cardinal;
+begin
+ if not InTable(ws, i, j, k) then
+ begin
+ result := -1;
+ end
+ else
+ begin
+// result := a_h[j, k].index;
+ result := PlkHashItem(a_x[j].Items[k])^.index;
+ end;
+end;
+
+function TlkHashTable.InTable(const ws: WideString; var i, j, k:
+ cardinal):
+ Boolean;
+var
+ l, wu, wl: Integer;
+ x: Cardinal;
+ fin: Boolean;
+begin
+ i := HashOf(ws);
+ j := i and $FF;
+ result := false;
+{using "binary" search always, because array is sorted}
+ if a_x[j].Count-1 >= 0 then
+ begin
+ wl := 0;
+ wu := a_x[j].Count-1;
+ repeat
+ fin := true;
+ if PlkHashItem(a_x[j].Items[wl])^.hash = i then
+ begin
+ k := wl;
+ result := true;
+ end
+ else if PlkHashItem(a_x[j].Items[wu])^.hash = i then
+ begin
+ k := wu;
+ result := true;
+ end
+ else if (wu - wl) > 1 then
+ begin
+ fin := false;
+ x := (wl + wu) shr 1;
+ if PlkHashItem(a_x[j].Items[x])^.hash > i then
+ begin
+ wu := x;
+ end
+ else
+ begin
+ wl := x;
+ end;
+ end;
+ until fin;
+ end;
+
+// verify k index in chain
+ if result = true then
+ begin
+ while (k > 0) and (PlkHashItem(a_x[j].Items[k])^.hash = PlkHashItem(a_x[j].Items[k-1])^.hash) do dec(k);
+ repeat
+ fin := true;
+ if TlkJSONobject(FParent).GetNameOf(PlkHashItem(a_x[j].Items[k])^.index) <> ws then
+ begin
+ if k < a_x[j].Count-1 then
+ begin
+ inc(k);
+ fin := false;
+ end
+ else
+ begin
+ result := false;
+ end;
+ end
+ else
+ begin
+ result := true;
+ end;
+ until fin;
+ end;
+end;
+
+{$IFNDEF THREADSAFE}
+
+procedure init_rnd;
+var
+ x0: Integer;
+ i: Integer;
+begin
+ x0 := 5;
+ for i := 0 to 255 do
+ begin
+ x0 := (x0 * 29 + 71) and $FF;
+ rnd_table[i] := x0;
+ end;
+end;
+{$ENDIF}
+
+procedure TlkHashTable.SetHashFunction(const AValue:
+ TlkHashFunction);
+begin
+ FHashFunction := AValue;
+end;
+
+constructor TlkHashTable.Create;
+var
+ i: Integer;
+begin
+ inherited;
+// for i := 0 to 255 do SetLength(a_h[i], 0);
+ for i := 0 to 255 do a_x[i] := TList.Create;
+ HashOf := {$IFDEF FPC}@{$ENDIF}DefaultHashOf;
+end;
+
+destructor TlkHashTable.Destroy;
+var
+ i, j: Integer;
+begin
+// for i := 0 to 255 do SetLength(a_h[i], 0);
+ for i := 0 to 255 do
+ begin
+ for j := 0 to a_x[i].Count - 1 do Freemem(a_x[i].Items[j]);
+ a_x[i].Free;
+ end;
+ inherited;
+end;
+
+function TlkHashTable.SimpleHashOf(const ws: WideString): cardinal;
+var
+ i: Integer;
+begin
+ result := length(ws);
+ for i := 1 to length(ws) do result := result + ord(ws[i]);
+end;
+{$ENDIF USE_HASH}
+
+{ TlkJSONstreamed }
+{$IFNDEF KOL}
+
+class function TlkJSONstreamed.LoadFromFile(srcname: string):
+ TlkJSONbase;
+var
+ fs: TFileStream;
+begin
+ result := nil;
+ if not FileExists(srcname) then exit;
+ try
+ fs := TFileStream.Create(srcname, fmOpenRead);
+ result := LoadFromStream(fs);
+ finally
+ if Assigned(fs) then FreeAndNil(fs);
+ end;
+end;
+
+class function TlkJSONstreamed.LoadFromStream(src: TStream):
+ TlkJSONbase;
+var
+ ws: string;
+ len: int64;
+begin
+ result := nil;
+ if not assigned(src) then exit;
+ len := src.Size - src.Position;
+ SetLength(ws, len);
+ src.Read(pchar(ws)^, len);
+ result := ParseText(ws);
+end;
+
+class procedure TlkJSONstreamed.SaveToFile(obj: TlkJSONbase;
+ dstname: string);
+var
+ fs: TFileStream;
+begin
+ if not assigned(obj) then exit;
+ try
+ fs := TFileStream.Create(dstname, fmCreate);
+ SaveToStream(obj, fs);
+ finally
+ if Assigned(fs) then FreeAndNil(fs);
+ end;
+end;
+
+class procedure TlkJSONstreamed.SaveToStream(obj: TlkJSONbase;
+ dst: TStream);
+var
+ ws: string;
+begin
+ if not assigned(obj) then exit;
+ if not assigned(dst) then exit;
+ ws := GenerateText(obj);
+ dst.Write(pchar(ws)^, length(ws));
+end;
+
+{$ENDIF}
+
+{ TlkJSONdotnetclass }
+
+{$IFDEF DOTNET}
+
+procedure TlkJSONdotnetclass.AfterConstruction;
+begin
+
+end;
+
+procedure TlkJSONdotnetclass.BeforeDestruction;
+begin
+
+end;
+
+constructor TlkJSONdotnetclass.Create;
+begin
+ inherited;
+ AfterConstruction;
+end;
+
+destructor TlkJSONdotnetclass.Destroy;
+begin
+ BeforeDestruction;
+ inherited;
+end;
+{$ENDIF DOTNET}
+
+{ TlkBalTree }
+
+{$IFNDEF USE_HASH}
+procedure TlkBalTree.Clear;
+
+ procedure rec(t: PlkBalNode);
+ begin
+ if t.left<>fbottom then rec(t.left);
+ if t.right<>fbottom then rec(t.right);
+ t.nm := '';
+ dispose(t);
+ end;
+
+begin
+ if froot<>fbottom then rec(froot);
+ froot := fbottom;
+ fdeleted := fbottom;
+end;
+
+function TlkBalTree.counters: string;
+begin
+ result := format('Balanced tree root node level is %d',[froot.level]);
+end;
+
+constructor TlkBalTree.Create;
+begin
+ inherited Create;
+ new(fbottom);
+ fbottom.left := fbottom;
+ fbottom.right := fbottom;
+ fbottom.level := 0;
+ fdeleted := fbottom;
+ froot := fbottom;
+end;
+
+function TlkBalTree.Delete(const ws: WideString): Boolean;
+
+ procedure UpdateKeys(t: PlkBalNode; idx: integer);
+ begin
+ if t <> fbottom then begin
+ if t.key > idx then
+ t.key := t.key - 1;
+ UpdateKeys(t.left, idx);
+ UpdateKeys(t.right, idx);
+ end;
+ end;
+
+ function del(var t: PlkBalNode): Boolean;
+ begin
+ result := false;
+ if t<>fbottom then begin
+ flast := t;
+ if ws fbottom) and (ws = fdeleted.nm) then begin
+ UpdateKeys(froot, fdeleted.key);
+ fdeleted.key := t.key;
+ fdeleted.nm := t.nm;
+ t := t.right;
+ flast.nm := '';
+ dispose(flast);
+ result := true;
+ end
+ else if (t.left.level < (t.level - 1)) or (t.right.level < (t.level - 1)) then begin
+ t.level := t.level - 1;
+ if t.right.level > t.level then
+ t.right.level := t.level;
+ skew(t);
+ skew(t.right);
+ skew(t.right.right);
+ split(t);
+ split(t.right);
+ end;
+ end;
+ end;
+
+{
+// mine version, buggy, see tracker message
+// [ 2229135 ] Value deletion is broken by "Nobody/Anonymous - nobody"
+
+ function del(var t: PlkBalNode): Boolean;
+ begin
+ result := false;
+ if t<>fbottom then
+ begin
+ flast := t;
+ if wsfbottom) and (ws = t.nm) then
+ begin
+ fdeleted.key := t.key;
+ fdeleted.nm := t.nm;
+ t := t.right;
+ flast.nm := '';
+ dispose(flast);
+ result := true;
+ end
+ else if (t.left.level<(t.level-1)) or (t.right.level<(t.level-1)) then
+ begin
+ t.level := t.level-1;
+ if t.right.level>t.level then t.right.level := t.level;
+ skew(t);
+ skew(t.right);
+ skew(t.right.right);
+ split(t);
+ split(t.right);
+ end;
+ end;
+ end;
+}
+
+begin
+ result := del(froot);
+end;
+
+destructor TlkBalTree.Destroy;
+begin
+ Clear;
+ dispose(fbottom);
+ inherited;
+end;
+
+function TlkBalTree.IndexOf(const ws: WideString): Integer;
+var
+ tk: PlkBalNode;
+begin
+ result := -1;
+ tk := froot;
+ while (result=-1) and (tk<>fbottom) do
+ begin
+ if tk.nm = ws then result := tk.key
+ else if ws t.nm then
+ result := ins(t.right)
+ else result := false;
+ skew(t);
+ split(t);
+ end;
+ end;
+
+begin
+ result := ins(froot);
+end;
+
+procedure TlkBalTree.skew(var t: PlkBalNode);
+var
+ temp: PlkBalNode;
+begin
+ if t.left.level = t.level then
+ begin
+ temp := t;
+ t := t.left;
+ temp.left := t.right;
+ t.right := temp;
+ end;
+end;
+
+procedure TlkBalTree.split(var t: PlkBalNode);
+var
+ temp: PlkBalNode;
+begin
+ if t.right.right.level = t.level then
+ begin
+ temp := t;
+ t := t.right;
+ temp.right := t.left;
+ t.left := temp;
+ t.level := t.level+1;
+ end;
+end;
+{$ENDIF USE_HASH}
+
+initialization
+{$IFNDEF THREADSAFE}
+{$IFDEF USE_HASH}
+ init_rnd;
+{$ENDIF USE_HASH}
+{$ENDIF THREADSAFE}
+end.
+
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.dpr" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.dpr"
new file mode 100644
index 0000000..6388703
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.dpr"
@@ -0,0 +1,16 @@
+program JSON_Test_D2007;
+
+uses
+ Forms,
+ uLkJSON in 'uLkJSON.pas',
+ main in 'main.pas' {Form1};
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.dproj" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.dproj"
new file mode 100644
index 0000000..01486c9
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.dproj"
@@ -0,0 +1,146 @@
+
+
+ {b8d02dd2-c5bc-47d3-b6b8-d58a9a2f0956}
+ JSONTest.dpr
+ Debug
+ AnyCPU
+ DCC32
+ ..\..\..\bin\JSONTest.exe
+
+
+ 7.0
+ False
+ False
+ 0
+ RELEASE
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+
+
+ 7.0
+ DEBUG
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\bin
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+
+
+ Delphi.Personality
+ VCLApplication
+
+
+ False
+ True
+ False
+
+
+ True
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 1033
+ 1252
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ CodeGear C++Builder Office 2000 Servers Package
+ CodeGear C++Builder Office XP Servers Package
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+
+
+ JSONTest.dpr
+
+
+
+
+
+
+ MainSource
+
+
+
+
+
+
+
\ No newline at end of file
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.res" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.res"
new file mode 100644
index 0000000..b3baee1
Binary files /dev/null and "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest.res" differ
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_Icon2.ico" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_Icon2.ico"
new file mode 100644
index 0000000..9917d72
Binary files /dev/null and "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_Icon2.ico" differ
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007.dpr" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007.dpr"
new file mode 100644
index 0000000..bf68606
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007.dpr"
@@ -0,0 +1,18 @@
+program JSONTest;
+
+uses
+ Forms,
+ Unit2 in 'Unit2.pas' {Form2},
+ uJSON in 'uJSON.pas',
+ uLkJSON in 'uLkJSON.pas',
+ YxdJson in 'YxdJson.pas';
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm2, Form2);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007.dproj" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007.dproj"
new file mode 100644
index 0000000..e25dcb3
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007.dproj"
@@ -0,0 +1,101 @@
+
+
+ {B3E2FA67-2D5C-40C1-A563-16FA8B349EFC}
+ JSONTest_d2007.dpr
+ True
+ Debug
+ 1
+ Application
+ VCL
+ 15.4
+ Win32
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ false
+ JSONTest_d2007
+ false
+ false
+ false
+ 00400000
+ Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)
+ 2052
+ false
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=
+
+
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
+ true
+ 1033
+ Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
+ $(BDS)\bin\default_app.manifest
+
+
+ RELEASE;$(DCC_Define)
+ 0
+ 0
+ false
+
+
+ DEBUG;$(DCC_Define)
+ true
+ false
+
+
+
+ MainSource
+
+
+
+
+
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+ Delphi.Personality.12
+
+
+
+
+ JSONTest_d2007.dpr
+
+
+
+ True
+ False
+
+
+ 12
+
+
+
+
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007_Icon.ico" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007_Icon.ico"
new file mode 100644
index 0000000..2bc1f2c
Binary files /dev/null and "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSONTest_d2007_Icon.ico" differ
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_D2007.dproj" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_D2007.dproj"
new file mode 100644
index 0000000..b1f303a
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_D2007.dproj"
@@ -0,0 +1,101 @@
+
+
+
+ {2778da2e-1090-4b05-b789-1366e08ab8a3}
+ Release
+ AnyCPU
+ DCC32
+ ..\..\..\bin\JSONTest.exe
+ JSONTest.dpr
+
+
+ 7.0
+ False
+ False
+ 0
+ RELEASE
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+
+
+ 7.0
+ DEBUG
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\dcu
+ ..\..\..\bin
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+ ..\..\..\source\;..\..\..\qdac\
+
+
+ Delphi.Personality
+
+
+FalseTrueFalseTrueFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0JSONTest.dpr
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ CodeGear C++Builder Office 2000 Servers Package
+ CodeGear C++Builder Office XP Servers Package
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+
+
+
+
+
+
+ MainSource
+
+
+
+
+
+
+
+
\ No newline at end of file
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_D2007.res" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_D2007.res"
new file mode 100644
index 0000000..b3baee1
Binary files /dev/null and "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_D2007.res" differ
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.dpr" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.dpr"
new file mode 100644
index 0000000..9c61ee9
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.dpr"
@@ -0,0 +1,16 @@
+program JSON_Test_XE;
+
+uses
+ Forms,
+ uLkJSON in 'uLkJSON.pas',
+ main in 'main.pas' {Form1};
+
+{$R *.res}
+
+begin
+ ReportMemoryLeaksOnShutdown := True;
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.dproj" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.dproj"
new file mode 100644
index 0000000..f10a728
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.dproj"
@@ -0,0 +1,183 @@
+
+
+ {2778da2e-1090-4b05-b789-1366e08ab8a3}
+ Debug
+ DCC32
+ bin\JSONTest.exe
+ JSON_Test_XE.dpr
+ True
+ Release
+ 3
+ Application
+ VCL
+ 15.4
+ Win32
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_1
+ true
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_2
+ true
+ true
+
+
+ JSON_Test_XE
+ Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)
+ 2052
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
+
+
+ System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
+ $(BDS)\bin\default_app.manifest
+ true
+ JSONTest_Icon2.ico
+ 1033
+
+
+ 1033
+ System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)
+ true
+ $(BDS)\bin\default_app.manifest
+ JSONTest_Icon2.ico
+
+
+ 7.0
+ 0
+ False
+ 0
+ RELEASE;$(DCC_Define)
+
+
+ ..\..\..\bin
+ ..\..\..\bin
+ true
+ ..\..\..\dcu
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ 1033
+ ..\..\..\dcu
+
+
+ 7.0
+ DEBUG;$(DCC_Define)
+ .\bin
+ .\dcu
+ .\dcu
+ .\dcu
+ .\bin
+ .\dcu
+
+
+ ..\..\..\dcu
+ ..\..\..\dcu
+ true
+ ..\..\..\bin
+ ..\..\..\source\;..\..\..\qdac\;$(DCC_UnitSearchPath)
+ 1033
+ ..\..\..\bin
+
+
+ Delphi.Personality.12
+
+
+
+
+ False
+ True
+ False
+
+
+ False
+ False
+ 1
+ 0
+ 0
+ 0
+ False
+ False
+ False
+ False
+ False
+ 2052
+ 936
+
+
+
+
+ 1.0.0.0
+
+
+
+
+
+ 1.0.0.0
+
+
+
+ JSON_Test_XE.dpr
+
+
+ Embarcadero C++Builder Office 2000 Servers Package
+ Embarcadero C++Builder Office XP Servers Package
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+
+
+
+ True
+ True
+
+
+ 12
+
+
+
+
+ MainSource
+
+
+
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+
+
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.res" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.res"
new file mode 100644
index 0000000..b60aad9
Binary files /dev/null and "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/JSON_Test_XE.res" differ
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/MSVCRT.LIB" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/MSVCRT.LIB"
new file mode 100644
index 0000000..e6a3686
Binary files /dev/null and "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/MSVCRT.LIB" differ
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/main.dfm" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/main.dfm"
new file mode 100644
index 0000000..e9b02f9
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/main.dfm"
@@ -0,0 +1,92 @@
+object Form1: TForm1
+ Left = 0
+ Top = 0
+ Caption = 'QJson Compare'
+ ClientHeight = 425
+ ClientWidth = 772
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Tahoma'
+ Font.Style = []
+ OldCreateOrder = False
+ OnCreate = FormCreate
+ PixelsPerInch = 96
+ TextHeight = 13
+ object Panel1: TPanel
+ Left = 0
+ Top = 0
+ Width = 772
+ Height = 49
+ Align = alTop
+ BevelOuter = bvNone
+ TabOrder = 0
+ object Button10: TButton
+ Left = 672
+ Top = 12
+ Width = 75
+ Height = 25
+ Caption = #24320#22987'(&S)'
+ TabOrder = 0
+ OnClick = Button10Click
+ end
+ object chkCreate: TCheckBox
+ Left = 16
+ Top = 16
+ Width = 97
+ Height = 17
+ Caption = #21019#24314#32467#28857
+ Checked = True
+ State = cbChecked
+ TabOrder = 1
+ end
+ object chkLoad: TCheckBox
+ Left = 123
+ Top = 16
+ Width = 97
+ Height = 17
+ Caption = #21152#36733#25991#20214
+ Checked = True
+ State = cbChecked
+ TabOrder = 2
+ end
+ object chkSave: TCheckBox
+ Left = 231
+ Top = 16
+ Width = 97
+ Height = 17
+ Caption = #20445#23384#25991#20214
+ Checked = True
+ State = cbChecked
+ TabOrder = 3
+ end
+ object chkTypes: TCheckBox
+ Left = 339
+ Top = 16
+ Width = 129
+ Height = 17
+ Caption = #35299#26512#19981#21516#31867#22411#25968#25454
+ Checked = True
+ State = cbChecked
+ TabOrder = 4
+ end
+ end
+ object mmResult: TMemo
+ Left = 0
+ Top = 49
+ Width = 772
+ Height = 376
+ Align = alClient
+ ImeName = #20013#25991' - QQ'#20116#31508#36755#20837#27861
+ TabOrder = 1
+ end
+ object OpenDialog1: TOpenDialog
+ Left = 48
+ Top = 104
+ end
+ object SaveDialog1: TSaveDialog
+ Left = 16
+ Top = 96
+ end
+end
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/main.pas" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/main.pas"
new file mode 100644
index 0000000..50138ad
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/main.pas"
@@ -0,0 +1,739 @@
+unit main;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Variants, Classes, Graphics,
+ Controls, Forms, Dialogs, StdCtrls, ExtCtrls, qstring, qjson;
+
+type
+ TForm1 = class(TForm)
+ Panel1: TPanel;
+ mmResult: TMemo;
+ OpenDialog1: TOpenDialog;
+ SaveDialog1: TSaveDialog;
+ Button10: TButton;
+ chkCreate: TCheckBox;
+ chkLoad: TCheckBox;
+ chkSave: TCheckBox;
+ chkTypes: TCheckBox;
+ procedure Button1Click(Sender: TObject);
+ procedure Button3Click(Sender: TObject);
+ procedure Button4Click(Sender: TObject);
+ procedure Button5Click(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure Button7Click(Sender: TObject);
+ procedure Button8Click(Sender: TObject);
+ procedure Button10Click(Sender: TObject);
+ private
+ { Private declarations }
+ procedure CreateTest;
+ procedure LoadTest;
+ procedure SaveTest;
+ procedure IOTest;
+ procedure TypeTest;
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+{$R *.dfm}
+uses uLkJSON,superobject,yxdjson;
+
+function GetFileSize(AFileName:String):Int64;
+var
+ sr:TSearchRec;
+ AHandle:Integer;
+begin
+AHandle:=FindFirst(AFileName,faAnyFile,sr);
+if AHandle=0 then
+ begin
+ Result:=sr.Size;
+ FindClose(sr);
+ end
+else
+ Result:=0;
+end;
+
+procedure TForm1.Button10Click(Sender: TObject);
+var
+ T:Cardinal;
+begin
+Button10.Enabled:=False;
+T:=GetTickCount;
+mmResult.Lines.Add('Կʼ');
+Caption:='Դ10ٶ...';
+Update;
+if chkCreate.Checked then
+ CreateTest;
+Caption:='Լٶ...';
+Update;
+if chkLoad.Checked then
+ LoadTest;
+Caption:='Աٶ...';
+Update;
+if chkSave.Checked then
+ SaveTest;
+Caption:='Բͬͽٶ...';
+Update;
+if chkTypes.Checked then
+ TypeTest;
+Caption:='JSON Compare';
+mmResult.Lines.Add('Խʱ'+RollupTime((GetTickCount-T) div 1000));
+Button10.Enabled:=True;
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+ AJson:TQJson;
+ I:Integer;
+ T:Cardinal;
+begin
+AJson:=TQJson.Create;
+try
+ T:=GetTickCount;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),Now);
+ T:=GetTickCount-T;
+ mmResult.Clear;
+ mmResult.Lines.Add('100,000ʱ:'+IntToStr(T)+'ms');
+finally
+ AJson.Free;
+end;
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+var
+ AJson:TQJson;
+ T:Cardinal;
+ Speed:Cardinal;
+ lkJson:TlkJSONbase;
+
+begin
+if OpenDialog1.Execute then
+ begin
+// uJsonTest;
+ AJson:=TQJson.Create;
+ try
+ T:=GetTickCount;
+ AJson.LoadFromFile(OpenDialog1.FileName,QString.teUtf8);
+ T:=GetTickCount-T;
+ if T>0 then
+ Speed:=(GetFileSize(OpenDialog1.FileName)*1000 div T)
+ else
+ Speed:=0;
+ mmResult.Clear;
+// mmResult.Lines.Add('صJSONļݣ');
+// mmResult.Lines.Add(AJson.Encode(True));
+ mmResult.Lines.Add('QJsonʱ:'+IntToStr(T)+'msٶ:'+RollupSize(Speed));
+ T:=GetTickCount;
+ lkJson:=TlkJSONstreamed.LoadFromFile(OpenDialog1.FileName);
+ T:=GetTickCount-T;
+ if T>0 then
+ Speed:=(GetFileSize(OpenDialog1.FileName)*1000 div T)
+ else
+ Speed:=0;
+ mmResult.Lines.Add('lkJsonʱ:'+IntToStr(T)+'msٶ:'+RollupSize(Speed));
+ lkJson.Free;
+ finally
+ AJson.Free;
+ end;
+ end;
+end;
+
+procedure TForm1.Button4Click(Sender: TObject);
+var
+ AJson:TQJson;
+ I:Integer;
+ T1,T2:Cardinal;
+ Speed:Cardinal;
+begin
+if SaveDialog1.Execute then
+ begin
+ AJson:=TQJson.Create;
+ try
+ mmResult.Clear;
+ T1:=GetTickCount;
+ with AJson.Add('Integers',qjson.jdtObject) do
+ begin
+ for I := 0 to 1000000 do
+ Add('Node'+IntToStr(I)).AsInteger :=I;
+ end;
+ T1:=GetTickCount-T1;
+ T2:=GetTickCount;
+ AJson.SaveToFile(SaveDialog1.FileName,qstring.teAnsi,false);
+ T2:=GetTickCount-T2;
+ if T2>0 then
+ Speed:=(GetFileSize(SaveDialog1.FileName)*1000 div T2)
+ else
+ Speed:=0;
+ mmResult.Lines.Add('10ʱ'+IntToStr(T1)+'ms,ʱ:'+IntToStr(T2)+'msٶȣ'+RollupSize(Speed));
+ finally
+ AJson.Free;
+ end;
+ end;
+end;
+
+procedure TForm1.Button5Click(Sender: TObject);
+var
+ AJson:TQJson;
+begin
+AJson:=TQJson.Create;
+try
+ AJson.Parse('{"results":[],"status":102,"msg":"IP\/SN\/SCODE\/REFERER Illegal:"}');
+// '{"name":"object_0","Id":1}');
+ ShowMessage(AJson.Encode(True));
+finally
+ AJson.Free;
+end;
+end;
+
+procedure TForm1.Button7Click(Sender: TObject);
+var
+ AStream:TMemoryStream;
+ AJson:TQJson;
+ S:QStringW;
+ AEncode:qstring.TTextEncoding;
+begin
+AStream:=TMemoryStream.Create;
+AJson:=TQJson.Create;
+try
+ AJson.DataType:=qjson.jdtObject;
+ S:='{"record1":{"id":100,"name":"name1"}}'#13#10+
+ '{"record2":{"id":200,"name":"name2"}}'#13#10+
+ '{"record3":{"id":300,"name":"name3"}}'#13#10;
+ //UCS2
+ mmResult.Lines.Add('Unicode 16 LE:');
+ AEncode:=qstring.teUnicode16LE;
+ AStream.Size:=0;
+ SaveTextW(AStream,S,False);
+ AStream.Position:=0;
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add('һν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ڶν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ν:');
+ mmResult.Lines.Add(AJson.AsJson);
+ //UTF-8
+ mmResult.Lines.Add('UTF8:');
+ AEncode:=qstring.teUtf8;
+ AStream.Size:=0;
+ SaveTextU(AStream,qstring.Utf8Encode(S),False);
+ AStream.Position:=0;
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'һν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ڶν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ν:');
+ mmResult.Lines.Add(AJson.AsJson);
+ //ANSI
+ mmResult.Lines.Add(#13#10'ANSI:');
+ AEncode:=qstring.teAnsi;
+ AStream.Size:=0;
+ SaveTextA(AStream,qstring.AnsiEncode(S));
+ AStream.Position:=0;
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add('һν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ڶν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ν:');
+ mmResult.Lines.Add(AJson.AsJson);
+ //UCS2BE
+ mmResult.Lines.Add(#13#10'Unicode16BE:');
+ AEncode:=qstring.teUnicode16BE;
+ AStream.Size:=0;
+ SaveTextWBE(AStream,S,False);
+ AStream.Position:=0;
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add('һν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ڶν:'#13#10);
+ mmResult.Lines.Add(AJson.AsJson);
+ AJson.Clear;
+ AJson.ParseBlock(AStream,AEncode);
+ mmResult.Lines.Add(#13#10'ν:');
+ mmResult.Lines.Add(AJson.AsJson);
+finally
+ AStream.Free;
+ AJson.Free;
+end;
+end;
+
+procedure TForm1.Button8Click(Sender: TObject);
+var
+ AJson,AItem:TQJson;
+begin
+AJson:=TQJson.Create;
+try
+ //ԪصNַʽʾ
+ // 1. ֱӵAddԪıķʽ
+ AJson.Add('AddArrayText','["Item1",100,null,true,false,123.4]',jdtArray);//jdtArrayʡԻԶԣȷ֪ͲҪжӿ
+ // 2. ֱ
+ AJson.Add('AddArray',['Item1',100,Null,True,False,123.4]);
+ // 3. ֱVarArrayOfֵ
+ AJson.Add('AsVariant').AsVariant:=VarArrayOf(['Item1',100,Null,True,False,123.4]);
+ // 4. ֱAsArrayļ
+ AJson.Add('AsArray').AsArray:='["Item1",100,null,true,false,123.4]';
+ // 5. ֶԪ
+ with AJson.Add('Manul') do
+ begin
+ DataType:=jdtArray;
+ Add.AsString:='Item1';
+ Add.AsInteger:=100;
+ Add;
+ Add.AsBoolean:=True;
+ Add.AsBoolean:=False;
+ Add.AsFloat:=123.4;
+ end;
+ // Ӷֻͣӽ㻻ǶͿ
+ AJson.Add('Object',[TQJson.Create.Add('Item1',100).Parent,TQJson.Create.Add('Item2',true).Parent]);
+ mmResult.Lines.Add(AJson.AsJson);
+finally
+ FreeObject(AJson);
+end;
+end;
+
+procedure TForm1.CreateTest;
+var
+ AJson:TQJson;
+ lkJson:TlkJSONobject;
+ lkItem:TlkJsonNumber;
+ SuperObj:ISuperObject;
+ YJson:JSONObject;
+ I:Integer;
+ T1,T2,T3,T4:Cardinal;
+begin
+AJson:=TQJson.Create;
+SuperObj:=TSuperObject.Create;
+lkJson:=TlkJSONObject.Create;
+YJson:=JsonObject.Create;
+try
+ mmResult.Lines.Add('100,000');
+ T1:=GetTickCount;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),Now);
+ T1:=GetTickCount-T1;
+ T2:=GetTickCount;
+ for I := 0 to 100000 do
+ begin
+ lkJson.Add('_'+IntToStr(I),TlkJsonNumber.Generate(Now));
+ end;
+ T2:=GetTickCount-T2;
+ T3:=GetTickCount;
+ for I := 0 to 100000 do
+ SuperObj.D['_'+IntToStr(I)]:=Now;
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ for I := 0 to 100000 do
+ YJson.put('_'+IntToStr(I),Now);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' Խ:QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+',T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+finally
+ AJson.Free;
+ lkJson.Free;
+ yJson.Free;
+end;
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ReportMemoryLeaksOnShutdown:=True;
+end;
+
+procedure TForm1.IOTest;
+begin
+
+end;
+
+procedure TForm1.LoadTest;
+var
+ I:Integer;
+ auk:TlkJSONbase;
+ AJson:TQJson;
+ SuperObj:ISuperObject;
+ YJson:JsonObject;
+ T1,T2,T3,T4:Cardinal;
+const
+ AFileName:String='Preferences.txt';
+ procedure PreCache;
+ var
+ AStream:TMemoryStream;
+ begin
+ AStream:=TMemoryStream.Create;
+ try
+ AStream.LoadFromFile(AFileName);
+ finally
+ AStream.Free;
+ end;
+ end;
+begin
+PreCache;
+mmResult.Lines.Add('Լļٶ');
+AJson:=TQJson.Create;
+T1:=GetTickCount;
+for I := 0 to 10 do
+ AJson.LoadFromFile(AFileName);
+T1:=GetTickCount-T1;
+AJson.Free;
+T2:=GetTickCount;
+for I := 0 to 10 do
+ begin
+ auk:=TlkJSONstreamed.LoadFromFile(AFileName);
+ auk.Free;
+ end;
+T2:=GetTickCount-T2;
+T3:=GetTickCount;
+for I := 0 to 10 do
+ SuperObj:=TSuperObject.ParseFile(AFileName,false);
+T3:=GetTickCount-T3;
+YJson:=JsonObject.Create;
+T4:=GetTickCount;
+for I := 0 to 10 do
+ YJson.LoadFromFile(AFileName);
+T4:=GetTickCount-T4;
+YJson.Free;
+mmResult.Lines.Add(' Խ:QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+end;
+
+procedure TForm1.SaveTest;
+var
+ I:Integer;
+ auk:TlkJSONbase;
+ AJson:TQJson;
+ YJson:JsonObject;
+ SuperObj:ISuperObject;
+ T1,T2,T3,T4:Cardinal;
+const
+ AFileName:String='Preferences.txt';
+ ASaveFileName:String='saved.json';
+ ACount:Integer=1;
+begin
+AJson:=TQJson.Create;
+AJson.LoadFromFile(AFileName);
+mmResult.Lines.Add('Աļٶ');
+T1:=GetTickCount;
+for I := 0 to ACount do
+ AJson.SaveToFile(ASaveFileName,qstring.teUnicode16LE,true);
+T1:=GetTickCount-T1;
+AJson.Free;
+auk:=TlkJSONstreamed.LoadFromFile(AFileName);
+T2:=GetTickCount;
+for I := 0 to ACount do
+ begin
+ TlkJSONStreamed.SaveToFile(auk,ASaveFileName);
+ end;
+T2:=GetTickCount-T2;
+auk.Free;
+//SuperObj:=TSuperObject.ParseFile(AFileName,false);
+T3:=GetTickCount;
+//for I := 0 to ACount do
+// SuperObj.SaveTo(ASaveFileName);
+// SuperObj:=TSuperObject.ParseFile(AFileName,false);
+T3:=GetTickCount-T3 + 10000;
+YJson:=JsonObject.Create;
+YJson.LoadFromFile(AFileName);
+T4:=GetTickCount;
+for I := 0 to ACount do
+ YJson.SaveToFile(ASaveFileName);
+T4:=GetTickCount-T4;
+YJson.Free;
+
+if T2 = 0 then T2 := 1;
+mmResult.Lines.Add(' Խ:QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+
+ FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+end;
+
+procedure TForm1.TypeTest;
+var
+ auk:TlkJSONbase;
+ AJson:TQJson;
+ SuperObj:ISuperObject;
+ YJson:JsonObject;
+ S:WideString;
+ AStream:TMemoryStream;
+ T1,T2,T3,T4:Cardinal;
+ Ansi:AnsiString;
+ procedure TestLongString;
+ var
+ I:Integer;
+ begin
+ SetLength(S,10*1024*1024);
+ for I := 0 to Length(S)-1 do
+ PWideChar(S)[I]:=WideChar(Ord('a')+random(26));
+ AJson.Clear;
+ AJson.Add('LongString',S,qjson.jdtString);
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' ַ:QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,YJson='+IntToStr(T4)+', T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+ function RandomString(ALen:Integer):QStringW;
+ var
+ I:Integer;
+ p:PQCharW;
+ begin
+ SetLength(Result,ALen);
+ p:=PWideChar(Result);
+ for I := 0 to ALen-1 do
+ p[I]:=WideChar(Ord('A')+56);
+ end;
+ procedure TestString;
+ var
+ I:Integer;
+ begin
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),RandomString(20),qjson.jdtString);
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' ַ:QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+ procedure TestInteger;
+ var
+ I:Integer;
+ begin
+ AJson.Clear;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),I);
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' :QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+
+ procedure TestNumeric;
+ var
+ I:Integer;
+ begin
+ AJson.Clear;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),I+random(10000)*0.0001);
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' :QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+
+ procedure TestBoolean;
+ var
+ I:Integer;
+ begin
+ AJson.Clear;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),random(10)>5);
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' :QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+
+ procedure TestNull;
+ var
+ I:Integer;
+ begin
+ AJson.Clear;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I));
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' ֵ:QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+
+ procedure TestObject;
+ var
+ I:Integer;
+ begin
+ AJson.Clear;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),'{"name":"object_'+IntToStr(I)+'"}');
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' :QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+
+ procedure TestArray;
+ var
+ I:Integer;
+ begin
+ AJson.Clear;
+ for I := 0 to 100000 do
+ AJson.Add('_'+IntToStr(I),'["name",'+IntToStr(I)+']');
+ S:=AJson.AsJson;
+ T1:=GetTickCount;
+ AJson.Parse(S);
+ T1:=GetTickCount-T1;
+ Ansi:=S;
+ T2:=GetTickCount;
+ auk:=TlkJson.ParseText(Ansi);
+ T2:=GetTickCount-T2;
+ auk.Free;
+ T3:=GetTickCount;
+ SuperObj:=TSuperObject.ParseString(PWideChar(S),False);
+ T3:=GetTickCount-T3;
+ T4:=GetTickCount;
+ YJson.parse(S);
+ T4:=GetTickCount-T4;
+ mmResult.Lines.Add(' :QJson='+IntToStr(T1)+'ms,lkJson='+IntToStr(T2)+
+ 'ms,SuperObject='+IntToStr(T3)+'ms,YJson='+IntToStr(T4)+'ms,T1/T2='+FormatFloat('0.##',T1*1.0/T2)+',T1/T3='+
+ FormatFloat('0.##',T1*1.0/T3)+',T1/T4='+FormatFloat('0.##',T1*1.0/T4)
+ );
+ end;
+
+begin
+mmResult.Lines.Add('Բͬݽٶ');
+AJson:=TQJson.Create;
+AJson.DataType:=qjson.jdtObject;
+YJson:=JsonObject.Create;
+TestLongString;
+TestString;
+TestInteger;
+TestNumeric;
+TestBoolean;
+TestNull;
+TestObject;
+TestArray;
+AJson.Free;
+YJson.Free;
+end;
+
+end.
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/superobject.pas" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/superobject.pas"
new file mode 100644
index 0000000..191d53d
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/superobject.pas"
@@ -0,0 +1,6555 @@
+(*
+ * Super Object Toolkit
+ *
+ * Usage allowed under the restrictions of the Lesser GNU General Public License
+ * or alternatively the restrictions of the Mozilla Public License 1.1
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ * the specific language governing rights and limitations under the License.
+ *
+ * Unit owner : Henri Gourvest
+ * Web site : http://www.progdigy.com
+ *
+ * This unit is inspired from the json c lib:
+ * Michael Clark
+ * http://oss.metaparadigm.com/json-c/
+ *
+ * CHANGES:
+ * v1.2
+ * + support of currency data type
+ * + right trim unquoted string
+ * + read Unicode Files and streams (Litle Endian with BOM)
+ * + Fix bug on javadate functions + windows nt compatibility
+ * + Now you can force to parse only the canonical syntax of JSON using the stric parameter
+ * + Delphi 2010 RTTI marshalling
+ * v1.1
+ * + Double licence MPL or LGPL.
+ * + Delphi 2009 compatibility & Unicode support.
+ * + AsString return a string instead of PChar.
+ * + Escaped and Unascaped JSON serialiser.
+ * + Missed FormFeed added \f
+ * - Removed @ trick, uses forcepath() method instead.
+ * + Fixed parse error with uppercase E symbol in numbers.
+ * + Fixed possible buffer overflow when enlarging array.
+ * + Added "delete", "pack", "insert" methods for arrays and/or objects
+ * + Multi parametters when calling methods
+ * + Delphi Enumerator (for obj1 in obj2 do ...)
+ * + Format method ex: obj.format('<%name%>%tab[1]%')
+ * + ParseFile and ParseStream methods
+ * + Parser now understand hexdecimal c syntax ex: \xFF
+ * + Null Object Design Patern (ex: for obj in values.N['path'] do ...)
+ * v1.0
+ * + renamed class
+ * + interfaced object
+ * + added a new data type: the method
+ * + parser can now evaluate properties and call methods
+ * - removed obselet rpc class
+ * - removed "find" method, now you can use "parse" method instead
+ * v0.6
+ * + refactoring
+ * v0.5
+ * + new find method to get or set value using a path syntax
+ * ex: obj.s['obj.prop[1]'] := 'string value';
+ * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary
+ * v0.4
+ * + bug corrected: AVL tree badly balanced.
+ * v0.3
+ * + New validator partially based on the Kwalify syntax.
+ * + extended syntax to parse unquoted fields.
+ * + Freepascal compatibility win32/64 Linux32/64.
+ * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC.
+ * + new TJsonObject.Compare function.
+ * v0.2
+ * + Hashed string list replaced with a faster AVL tree
+ * + JsonInt data type can be changed to int64
+ * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions
+ * + from json-c v0.7
+ * + Add escaping of backslash to json output
+ * + Add escaping of foward slash on tokenizing and output
+ * + Changes to internal tokenizer from using recursion to
+ * using a depth state structure to allow incremental parsing
+ * v0.1
+ * + first release
+ *)
+
+{$IFDEF FPC}
+ {$MODE OBJFPC}{$H+}
+{$ENDIF}
+
+{$DEFINE SUPER_METHOD}
+{$DEFINE WINDOWSNT_COMPATIBILITY}
+{.$DEFINE DEBUG} // track memory leack
+
+unit superobject;
+
+interface
+uses
+ Classes
+{$IFDEF VER210}
+ ,Generics.Collections, RTTI, TypInfo
+{$ENDIF}
+ ;
+
+type
+{$IFNDEF FPC}
+ PtrInt = longint;
+ PtrUInt = Longword;
+{$ENDIF}
+ SuperInt = Int64;
+
+{$if (sizeof(Char) = 1)}
+ SOChar = WideChar;
+ SOIChar = Word;
+ PSOChar = PWideChar;
+ SOString = WideString;
+{$else}
+ SOChar = Char;
+ SOIChar = Word;
+ PSOChar = PChar;
+ SOString = string;
+{$ifend}
+
+const
+ SUPER_ARRAY_LIST_DEFAULT_SIZE = 32;
+ SUPER_TOKENER_MAX_DEPTH = 32;
+
+ SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8;
+ SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1);
+
+type
+ // forward declarations
+ TSuperObject = class;
+ ISuperObject = interface;
+ TSuperArray = class;
+
+(* AVL Tree
+ * This is a "special" autobalanced AVL tree
+ * It use a hash value for fast compare
+ *)
+
+{$IFDEF SUPER_METHOD}
+ TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject);
+{$ENDIF}
+
+
+ TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1;
+
+ TSuperAvlSearchType = (stEQual, stLess, stGreater);
+ TSuperAvlSearchTypes = set of TSuperAvlSearchType;
+ TSuperAvlIterator = class;
+
+ TSuperAvlEntry = class
+ private
+ FGt, FLt: TSuperAvlEntry;
+ FBf: integer;
+ FHash: Cardinal;
+ FName: SOString;
+ FPtr: Pointer;
+ function GetValue: ISuperObject;
+ procedure SetValue(const val: ISuperObject);
+ public
+ class function Hash(const k: SOString): Cardinal; virtual;
+ constructor Create(const AName: SOString; Obj: Pointer); virtual;
+ property Name: SOString read FName;
+ property Ptr: Pointer read FPtr;
+ property Value: ISuperObject read GetValue write SetValue;
+ end;
+
+ TSuperAvlTree = class
+ private
+ FRoot: TSuperAvlEntry;
+ FCount: Integer;
+ function balance(bal: TSuperAvlEntry): TSuperAvlEntry;
+ protected
+ procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual;
+ function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual;
+ function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual;
+ function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual;
+ function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual;
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function IsEmpty: boolean;
+ procedure Clear(all: boolean = false); virtual;
+ procedure Pack(all: boolean);
+ function Delete(const k: SOString): ISuperObject;
+ function GetEnumerator: TSuperAvlIterator;
+ property count: Integer read FCount;
+ end;
+
+ TSuperTableString = class(TSuperAvlTree)
+ protected
+ procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override;
+ procedure PutO(const k: SOString; const value: ISuperObject);
+ function GetO(const k: SOString): ISuperObject;
+ procedure PutS(const k: SOString; const value: SOString);
+ function GetS(const k: SOString): SOString;
+ procedure PutI(const k: SOString; value: SuperInt);
+ function GetI(const k: SOString): SuperInt;
+ procedure PutD(const k: SOString; value: Double);
+ function GetD(const k: SOString): Double;
+ procedure PutB(const k: SOString; value: Boolean);
+ function GetB(const k: SOString): Boolean;
+{$IFDEF SUPER_METHOD}
+ procedure PutM(const k: SOString; value: TSuperMethod);
+ function GetM(const k: SOString): TSuperMethod;
+{$ENDIF}
+ procedure PutN(const k: SOString; const value: ISuperObject);
+ function GetN(const k: SOString): ISuperObject;
+ procedure PutC(const k: SOString; value: Currency);
+ function GetC(const k: SOString): Currency;
+ public
+ property O[const k: SOString]: ISuperObject read GetO write PutO; default;
+ property S[const k: SOString]: SOString read GetS write PutS;
+ property I[const k: SOString]: SuperInt read GetI write PutI;
+ property D[const k: SOString]: Double read GetD write PutD;
+ property B[const k: SOString]: Boolean read GetB write PutB;
+{$IFDEF SUPER_METHOD}
+ property M[const k: SOString]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+ property N[const k: SOString]: ISuperObject read GetN write PutN;
+ property C[const k: SOString]: Currency read GetC write PutC;
+
+ function GetValues: ISuperObject;
+ function GetNames: ISuperObject;
+ end;
+
+ TSuperAvlIterator = class
+ private
+ FTree: TSuperAvlTree;
+ FBranch: TSuperAvlBitArray;
+ FDepth: LongInt;
+ FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry;
+ public
+ constructor Create(tree: TSuperAvlTree); virtual;
+ procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]);
+ procedure First;
+ procedure Last;
+ function GetIter: TSuperAvlEntry;
+ procedure Next;
+ procedure Prior;
+ // delphi enumerator
+ function MoveNext: Boolean;
+ property Current: TSuperAvlEntry read GetIter;
+ end;
+
+ TSuperObjectArray = array[0..(high(PtrInt) div sizeof(TSuperObject))-1] of ISuperObject;
+ PSuperObjectArray = ^TSuperObjectArray;
+
+ TSuperArray = class
+ private
+ FArray: PSuperObjectArray;
+ FLength: Integer;
+ FSize: Integer;
+ procedure Expand(max: Integer);
+ protected
+ function GetO(const index: integer): ISuperObject;
+ procedure PutO(const index: integer; const Value: ISuperObject);
+ function GetB(const index: integer): Boolean;
+ procedure PutB(const index: integer; Value: Boolean);
+ function GetI(const index: integer): SuperInt;
+ procedure PutI(const index: integer; Value: SuperInt);
+ function GetD(const index: integer): Double;
+ procedure PutD(const index: integer; Value: Double);
+ function GetC(const index: integer): Currency;
+ procedure PutC(const index: integer; Value: Currency);
+ function GetS(const index: integer): SOString;
+ procedure PutS(const index: integer; const Value: SOString);
+{$IFDEF SUPER_METHOD}
+ function GetM(const index: integer): TSuperMethod;
+ procedure PutM(const index: integer; Value: TSuperMethod);
+{$ENDIF}
+ function GetN(const index: integer): ISuperObject;
+ procedure PutN(const index: integer; const Value: ISuperObject);
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function Add(const Data: ISuperObject): Integer;
+ function Delete(index: Integer): ISuperObject;
+ procedure Insert(index: Integer; const value: ISuperObject);
+ procedure Clear(all: boolean = false);
+ procedure Pack(all: boolean);
+ property Length: Integer read FLength;
+
+ property N[const index: integer]: ISuperObject read GetN write PutN;
+ property O[const index: integer]: ISuperObject read GetO write PutO; default;
+ property B[const index: integer]: boolean read GetB write PutB;
+ property I[const index: integer]: SuperInt read GetI write PutI;
+ property D[const index: integer]: Double read GetD write PutD;
+ property C[const index: integer]: Currency read GetC write PutC;
+ property S[const index: integer]: SOString read GetS write PutS;
+{$IFDEF SUPER_METHOD}
+ property M[const index: integer]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+// property A[const index: integer]: TSuperArray read GetA;
+ end;
+
+ TSuperWriter = class
+ public
+ // abstact methods to overide
+ function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract;
+ function Append(buf: PSOChar): Integer; overload; virtual; abstract;
+ procedure Reset; virtual; abstract;
+ end;
+
+ TSuperWriterString = class(TSuperWriter)
+ private
+ FBuf: PSOChar;
+ FBPos: integer;
+ FSize: integer;
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; overload; override;
+ function Append(buf: PSOChar): Integer; overload; override;
+ procedure Reset; override;
+ procedure TrimRight;
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function GetString: SOString;
+ property Data: PSOChar read FBuf;
+ property Size: Integer read FSize;
+ property Position: integer read FBPos;
+ end;
+
+ TSuperWriterStream = class(TSuperWriter)
+ private
+ FStream: TStream;
+ public
+ function Append(buf: PSOChar): Integer; override;
+ procedure Reset; override;
+ constructor Create(AStream: TStream); reintroduce; virtual;
+ end;
+
+ TSuperAnsiWriterStream = class(TSuperWriterStream)
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ end;
+
+ TSuperUnicodeWriterStream = class(TSuperWriterStream)
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ end;
+
+ TSuperWriterFake = class(TSuperWriter)
+ private
+ FSize: Integer;
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ function Append(buf: PSOChar): Integer; override;
+ procedure Reset; override;
+ constructor Create; reintroduce; virtual;
+ property size: integer read FSize;
+ end;
+
+ TSuperWriterSock = class(TSuperWriter)
+ private
+ FSocket: longint;
+ FSize: Integer;
+ public
+ function Append(buf: PSOChar; Size: Integer): Integer; override;
+ function Append(buf: PSOChar): Integer; override;
+ procedure Reset; override;
+ constructor Create(ASocket: longint); reintroduce; virtual;
+ property Socket: longint read FSocket;
+ property Size: Integer read FSize;
+ end;
+
+ TSuperTokenizerError = (
+ teSuccess,
+ teContinue,
+ teDepth,
+ teParseEof,
+ teParseUnexpected,
+ teParseNull,
+ teParseBoolean,
+ teParseNumber,
+ teParseArray,
+ teParseObjectKeyName,
+ teParseObjectKeySep,
+ teParseObjectValueSep,
+ teParseString,
+ teParseComment,
+ teEvalObject,
+ teEvalArray,
+ teEvalMethod,
+ teEvalInt
+ );
+
+ TSuperTokenerState = (
+ tsEatws,
+ tsStart,
+ tsFinish,
+ tsNull,
+ tsCommentStart,
+ tsComment,
+ tsCommentEol,
+ tsCommentEnd,
+ tsString,
+ tsStringEscape,
+ tsIdentifier,
+ tsEscapeUnicode,
+ tsEscapeHexadecimal,
+ tsBoolean,
+ tsNumber,
+ tsArray,
+ tsArrayAdd,
+ tsArraySep,
+ tsObjectFieldStart,
+ tsObjectField,
+ tsObjectUnquotedField,
+ tsObjectFieldEnd,
+ tsObjectValue,
+ tsObjectValueAdd,
+ tsObjectSep,
+ tsEvalProperty,
+ tsEvalArray,
+ tsEvalMethod,
+ tsParamValue,
+ tsParamPut,
+ tsMethodValue,
+ tsMethodPut
+ );
+
+ PSuperTokenerSrec = ^TSuperTokenerSrec;
+ TSuperTokenerSrec = record
+ state, saved_state: TSuperTokenerState;
+ obj: ISuperObject;
+ current: ISuperObject;
+ field_name: SOString;
+ parent: ISuperObject;
+ gparent: ISuperObject;
+ end;
+
+ TSuperTokenizer = class
+ public
+ str: PSOChar;
+ pb: TSuperWriterString;
+ depth, is_double, floatcount, st_pos, char_offset: Integer;
+ err: TSuperTokenizerError;
+ ucs_char: Word;
+ quote_char: SOChar;
+ stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec;
+ line, col: Integer;
+ public
+ constructor Create; virtual;
+ destructor Destroy; override;
+ procedure ResetLevel(adepth: integer);
+ procedure Reset;
+ end;
+
+ // supported object types
+ TSuperType = (
+ stNull,
+ stBoolean,
+ stDouble,
+ stCurrency,
+ stInt,
+ stObject,
+ stArray,
+ stString
+{$IFDEF SUPER_METHOD}
+ ,stMethod
+{$ENDIF}
+ );
+
+ TSuperValidateError = (
+ veRuleMalformated,
+ veFieldIsRequired,
+ veInvalidDataType,
+ veFieldNotFound,
+ veUnexpectedField,
+ veDuplicateEntry,
+ veValueNotInEnum,
+ veInvalidLength,
+ veInvalidRange
+ );
+
+ TSuperFindOption = (
+ foCreatePath,
+ foPutValue,
+ foDelete
+{$IFDEF SUPER_METHOD}
+ ,foCallMethod
+{$ENDIF}
+ );
+
+ TSuperFindOptions = set of TSuperFindOption;
+ TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError);
+ TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString);
+
+ TSuperEnumerator = class
+ private
+ FObj: ISuperObject;
+ FObjEnum: TSuperAvlIterator;
+ FCount: Integer;
+ public
+ constructor Create(const obj: ISuperObject); virtual;
+ destructor Destroy; override;
+ function MoveNext: Boolean;
+ function GetCurrent: ISuperObject;
+ property Current: ISuperObject read GetCurrent;
+ end;
+
+ ISuperObject = interface
+ ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}']
+ function GetEnumerator: TSuperEnumerator;
+ function GetDataType: TSuperType;
+ function GetProcessing: boolean;
+ procedure SetProcessing(value: boolean);
+ function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
+ function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
+
+ function GetO(const path: SOString): ISuperObject;
+ procedure PutO(const path: SOString; const Value: ISuperObject);
+ function GetB(const path: SOString): Boolean;
+ procedure PutB(const path: SOString; Value: Boolean);
+ function GetI(const path: SOString): SuperInt;
+ procedure PutI(const path: SOString; Value: SuperInt);
+ function GetD(const path: SOString): Double;
+ procedure PutC(const path: SOString; Value: Currency);
+ function GetC(const path: SOString): Currency;
+ procedure PutD(const path: SOString; Value: Double);
+ function GetS(const path: SOString): SOString;
+ procedure PutS(const path: SOString; const Value: SOString);
+{$IFDEF SUPER_METHOD}
+ function GetM(const path: SOString): TSuperMethod;
+ procedure PutM(const path: SOString; Value: TSuperMethod);
+{$ENDIF}
+ function GetA(const path: SOString): TSuperArray;
+
+ // Null Object Design patern
+ function GetN(const path: SOString): ISuperObject;
+ procedure PutN(const path: SOString; const Value: ISuperObject);
+
+ // Writers
+ function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
+ function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
+ function CalcSize(indent: boolean = false; escape: boolean = true): integer;
+
+ // convert
+ function AsBoolean: Boolean;
+ function AsInteger: SuperInt;
+ function AsDouble: Double;
+ function AsCurrency: Currency;
+ function AsString: SOString;
+ function AsArray: TSuperArray;
+ function AsObject: TSuperTableString;
+{$IFDEF SUPER_METHOD}
+ function AsMethod: TSuperMethod;
+{$ENDIF}
+ function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
+
+ procedure Clear(all: boolean = false);
+ procedure Pack(all: boolean = false);
+
+ property N[const path: SOString]: ISuperObject read GetN write PutN;
+ property O[const path: SOString]: ISuperObject read GetO write PutO; default;
+ property B[const path: SOString]: boolean read GetB write PutB;
+ property I[const path: SOString]: SuperInt read GetI write PutI;
+ property D[const path: SOString]: Double read GetD write PutD;
+ property C[const path: SOString]: Currency read GetC write PutC;
+ property S[const path: SOString]: SOString read GetS write PutS;
+{$IFDEF SUPER_METHOD}
+ property M[const path: SOString]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+ property A[const path: SOString]: TSuperArray read GetA;
+
+{$IFDEF SUPER_METHOD}
+ function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload;
+ function call(const path, param: SOString): ISuperObject; overload;
+{$ENDIF}
+ // clone a node
+ function Clone: ISuperObject;
+ function Delete(const path: SOString): ISuperObject;
+ // merges tow objects of same type, if reference is true then nodes are not cloned
+ procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
+ procedure Merge(const str: SOString); overload;
+
+ // validate methods
+ function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+ function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+
+ // compare
+ function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
+ function Compare(const str: SOString): TSuperCompareResult; overload;
+
+ // the data type
+ function IsType(AType: TSuperType): boolean;
+ property DataType: TSuperType read GetDataType;
+ property Processing: boolean read GetProcessing write SetProcessing;
+
+ function GetDataPtr: Pointer;
+ procedure SetDataPtr(const Value: Pointer);
+ property DataPtr: Pointer read GetDataPtr write SetDataPtr;
+ end;
+
+ TSuperObject = class(TObject, ISuperObject)
+ private
+ FRefCount: Integer;
+ FProcessing: boolean;
+ FDataType: TSuperType;
+ FDataPtr: Pointer;
+{.$if true}
+ FO: record
+ case TSuperType of
+ stBoolean: (c_boolean: boolean);
+ stDouble: (c_double: double);
+ stCurrency: (c_currency: Currency);
+ stInt: (c_int: SuperInt);
+ stObject: (c_object: TSuperTableString);
+ stArray: (c_array: TSuperArray);
+{$IFDEF SUPER_METHOD}
+ stMethod: (c_method: TSuperMethod);
+{$ENDIF}
+ end;
+{.$ifend}
+ FOString: SOString;
+ function GetDataType: TSuperType;
+ function GetDataPtr: Pointer;
+ procedure SetDataPtr(const Value: Pointer);
+ protected
+ function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
+ function _AddRef: Integer; virtual; stdcall;
+ function _Release: Integer; virtual; stdcall;
+
+ function GetO(const path: SOString): ISuperObject;
+ procedure PutO(const path: SOString; const Value: ISuperObject);
+ function GetB(const path: SOString): Boolean;
+ procedure PutB(const path: SOString; Value: Boolean);
+ function GetI(const path: SOString): SuperInt;
+ procedure PutI(const path: SOString; Value: SuperInt);
+ function GetD(const path: SOString): Double;
+ procedure PutD(const path: SOString; Value: Double);
+ procedure PutC(const path: SOString; Value: Currency);
+ function GetC(const path: SOString): Currency;
+ function GetS(const path: SOString): SOString;
+ procedure PutS(const path: SOString; const Value: SOString);
+{$IFDEF SUPER_METHOD}
+ function GetM(const path: SOString): TSuperMethod;
+ procedure PutM(const path: SOString; Value: TSuperMethod);
+{$ENDIF}
+ function GetA(const path: SOString): TSuperArray;
+ function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual;
+ public
+ function GetEnumerator: TSuperEnumerator;
+ procedure AfterConstruction; override;
+ procedure BeforeDestruction; override;
+ class function NewInstance: TObject; override;
+ property RefCount: Integer read FRefCount;
+
+ function GetProcessing: boolean;
+ procedure SetProcessing(value: boolean);
+
+ // Writers
+ function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload;
+ function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload;
+ function CalcSize(indent: boolean = false; escape: boolean = true): integer;
+ function AsJSon(indent: boolean = false; escape: boolean = true): SOString;
+
+ // parser ... owned!
+ class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
+ const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+ class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
+ const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+ class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = [];
+ const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+ class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil;
+ options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject;
+
+ // constructors / destructor
+ constructor Create(jt: TSuperType = stObject); overload; virtual;
+ constructor Create(b: boolean); overload; virtual;
+ constructor Create(i: SuperInt); overload; virtual;
+ constructor Create(d: double); overload; virtual;
+ constructor CreateCurrency(c: Currency); overload; virtual;
+ constructor Create(const s: SOString); overload; virtual;
+{$IFDEF SUPER_METHOD}
+ constructor Create(m: TSuperMethod); overload; virtual;
+{$ENDIF}
+ destructor Destroy; override;
+
+ // convert
+ function AsBoolean: Boolean; virtual;
+ function AsInteger: SuperInt; virtual;
+ function AsDouble: Double; virtual;
+ function AsCurrency: Currency; virtual;
+ function AsString: SOString; virtual;
+ function AsArray: TSuperArray; virtual;
+ function AsObject: TSuperTableString; virtual;
+{$IFDEF SUPER_METHOD}
+ function AsMethod: TSuperMethod; virtual;
+{$ENDIF}
+ procedure Clear(all: boolean = false); virtual;
+ procedure Pack(all: boolean = false); virtual;
+ function GetN(const path: SOString): ISuperObject;
+ procedure PutN(const path: SOString; const Value: ISuperObject);
+ function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
+ function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString;
+
+ property N[const path: SOString]: ISuperObject read GetN write PutN;
+ property O[const path: SOString]: ISuperObject read GetO write PutO; default;
+ property B[const path: SOString]: boolean read GetB write PutB;
+ property I[const path: SOString]: SuperInt read GetI write PutI;
+ property D[const path: SOString]: Double read GetD write PutD;
+ property C[const path: SOString]: Currency read GetC write PutC;
+ property S[const path: SOString]: SOString read GetS write PutS;
+{$IFDEF SUPER_METHOD}
+ property M[const path: SOString]: TSuperMethod read GetM write PutM;
+{$ENDIF}
+ property A[const path: SOString]: TSuperArray read GetA;
+
+{$IFDEF SUPER_METHOD}
+ function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual;
+ function call(const path, param: SOString): ISuperObject; overload; virtual;
+{$ENDIF}
+ // clone a node
+ function Clone: ISuperObject; virtual;
+ function Delete(const path: SOString): ISuperObject;
+ // merges tow objects of same type, if reference is true then nodes are not cloned
+ procedure Merge(const obj: ISuperObject; reference: boolean = false); overload;
+ procedure Merge(const str: SOString); overload;
+
+ // validate methods
+ function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+ function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload;
+
+ // compare
+ function Compare(const obj: ISuperObject): TSuperCompareResult; overload;
+ function Compare(const str: SOString): TSuperCompareResult; overload;
+
+ // the data type
+ function IsType(AType: TSuperType): boolean;
+ property DataType: TSuperType read GetDataType;
+ // a data pointer to link to something ele, a treeview for example
+ property DataPtr: Pointer read GetDataPtr write SetDataPtr;
+ property Processing: boolean read GetProcessing;
+ end;
+
+{$IFDEF VER210}
+ TSuperRttiContext = class;
+
+ TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+ TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+
+ TSuperAttribute = class(TCustomAttribute)
+ private
+ FName: string;
+ public
+ constructor Create(const AName: string);
+ property Name: string read FName;
+ end;
+
+ SOName = class(TSuperAttribute);
+ SODefault = class(TSuperAttribute);
+
+
+ TSuperRttiContext = class
+ private
+ class function GetFieldName(r: TRttiField): string;
+ class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
+ public
+ Context: TRttiContext;
+ SerialFromJson: TDictionary;
+ SerialToJson: TDictionary;
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual;
+ function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual;
+ function AsType(const obj: ISuperObject): T;
+ function AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject;
+ end;
+
+ TSuperObjectHelper = class helper for TObject
+ public
+ function ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
+ constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload;
+ constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload;
+ end;
+{$ENDIF}
+
+ TSuperObjectIter = record
+ key: SOString;
+ val: ISuperObject;
+ Ite: TSuperAvlIterator;
+ end;
+
+function ObjectIsError(obj: TSuperObject): boolean;
+function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
+function ObjectGetType(const obj: ISuperObject): TSuperType;
+
+function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
+function ObjectFindNext(var F: TSuperObjectIter): boolean;
+procedure ObjectFindClose(var F: TSuperObjectIter);
+
+function SO(const s: SOString = '{}'): ISuperObject; overload;
+function SO(const value: Variant): ISuperObject; overload;
+function SO(const Args: array of const): ISuperObject; overload;
+
+function SA(const Args: array of const): ISuperObject; overload;
+
+function JavaToDelphiDateTime(const dt: int64): TDateTime;
+function DelphiToJavaDateTime(const dt: TDateTime): int64;
+
+{$IFDEF VER210}
+
+type
+ TSuperInvokeResult = (
+ irSuccess,
+ irMethothodError, // method don't exist
+ irParamError, // invalid parametters
+ irError // other error
+ );
+
+function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload;
+function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload;
+function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload;
+{$ENDIF}
+
+implementation
+uses sysutils,
+{$IFDEF UNIX}
+ baseunix, unix, DateUtils
+{$ELSE}
+ Windows
+{$ENDIF}
+{$IFDEF FPC}
+ ,sockets
+{$ELSE}
+ ,WinSock
+{$ENDIF};
+
+{$IFDEF DEBUG}
+var
+ debugcount: integer = 0;
+{$ENDIF}
+
+const
+ super_number_chars_set = ['0'..'9','.','+','-','e','E'];
+ super_hex_chars: PSOChar = '0123456789abcdef';
+ super_hex_chars_set = ['0'..'9','a'..'f','A'..'F'];
+
+ ESC_BS: PSOChar = '\b';
+ ESC_LF: PSOChar = '\n';
+ ESC_CR: PSOChar = '\r';
+ ESC_TAB: PSOChar = '\t';
+ ESC_FF: PSOChar = '\f';
+ ESC_QUOT: PSOChar = '\"';
+ ESC_SL: PSOChar = '\\';
+ ESC_SR: PSOChar = '\/';
+ ESC_ZERO: PSOChar = '\u0000';
+
+ TOK_CRLF: PSOChar = #13#10;
+ TOK_SP: PSOChar = #32;
+ TOK_BS: PSOChar = #8;
+ TOK_TAB: PSOChar = #9;
+ TOK_LF: PSOChar = #10;
+ TOK_FF: PSOChar = #12;
+ TOK_CR: PSOChar = #13;
+// TOK_SL: PSOChar = '\';
+// TOK_SR: PSOChar = '/';
+ TOK_NULL: PSOChar = 'null';
+ TOK_CBL: PSOChar = '{'; // curly bracket left
+ TOK_CBR: PSOChar = '}'; // curly bracket right
+ TOK_ARL: PSOChar = '[';
+ TOK_ARR: PSOChar = ']';
+ TOK_ARRAY: PSOChar = '[]';
+ TOK_OBJ: PSOChar = '{}'; // empty object
+ TOK_COM: PSOChar = ','; // Comma
+ TOK_DQT: PSOChar = '"'; // Double Quote
+ TOK_TRUE: PSOChar = 'true';
+ TOK_FALSE: PSOChar = 'false';
+
+{$if (sizeof(Char) = 1)}
+function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer;
+var
+ P1, P2: PWideChar;
+ I: Cardinal;
+ C1, C2: WideChar;
+begin
+ P1 := Str1;
+ P2 := Str2;
+ I := 0;
+ while I < MaxLen do
+ begin
+ C1 := P1^;
+ C2 := P2^;
+
+ if (C1 <> C2) or (C1 = #0) then
+ begin
+ Result := Ord(C1) - Ord(C2);
+ Exit;
+ end;
+
+ Inc(P1);
+ Inc(P2);
+ Inc(I);
+ end;
+ Result := 0;
+end;
+
+function StrComp(const Str1, Str2: PSOChar): Integer;
+var
+ P1, P2: PWideChar;
+ C1, C2: WideChar;
+begin
+ P1 := Str1;
+ P2 := Str2;
+ while True do
+ begin
+ C1 := P1^;
+ C2 := P2^;
+
+ if (C1 <> C2) or (C1 = #0) then
+ begin
+ Result := Ord(C1) - Ord(C2);
+ Exit;
+ end;
+
+ Inc(P1);
+ Inc(P2);
+ end;
+end;
+
+function StrLen(const Str: PSOChar): Cardinal;
+var
+ p: PSOChar;
+begin
+ Result := 0;
+ if Str <> nil then
+ begin
+ p := Str;
+ while p^ <> #0 do inc(p);
+ Result := (p - Str);
+ end;
+end;
+{$ifend}
+
+function CurrToStr(c: Currency): SOString;
+var
+ p: PSOChar;
+ i, len: Integer;
+begin
+ Result := IntToStr(Abs(PInt64(@c)^));
+ len := Length(Result);
+ SetLength(Result, len+1);
+ if c <> 0 then
+ begin
+ while len <= 4 do
+ begin
+ Result := '0' + Result;
+ inc(len);
+ end;
+
+ p := PSOChar(Result);
+ inc(p, len-1);
+ i := 0;
+ repeat
+ if p^ <> '0' then
+ begin
+ len := len - i + 1;
+ repeat
+ p[1] := p^;
+ dec(p);
+ inc(i);
+ until i > 3;
+ Break;
+ end;
+ dec(p);
+ inc(i);
+ if i > 3 then
+ begin
+ len := len - i + 1;
+ Break;
+ end;
+ until false;
+ p[1] := '.';
+ SetLength(Result, len);
+ if c < 0 then
+ Result := '-' + Result;
+ end;
+end;
+
+{$IFDEF UNIX}
+ {$linklib c}
+{$ENDIF}
+function gcvt(value: Double; ndigit: longint; buf: PAnsiChar): PAnsiChar; cdecl;
+ external {$IFDEF MSWINDOWS} 'msvcrt.dll' name '_gcvt'{$ENDIF};
+
+{$IFDEF UNIX}
+type
+ ptm = ^tm;
+ tm = record
+ tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *)
+ tm_min: Integer; (* Minutes: 0-59 *)
+ tm_hour: Integer; (* Hours since midnight: 0-23 *)
+ tm_mday: Integer; (* Day of the month: 1-31 *)
+ tm_mon: Integer; (* Months *since* january: 0-11 *)
+ tm_year: Integer; (* Years since 1900 *)
+ tm_wday: Integer; (* Days since Sunday (0-6) *)
+ tm_yday: Integer; (* Days since Jan. 1: 0-365 *)
+ tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *)
+ end;
+
+function mktime(p: ptm): LongInt; cdecl; external;
+function gmtime(const t: PLongint): ptm; cdecl; external;
+function localtime (const t: PLongint): ptm; cdecl; external;
+
+function DelphiToJavaDateTime(const dt: TDateTime): Int64;
+var
+ p: ptm;
+ l, ms: Integer;
+ v: Int64;
+begin
+ v := Round((dt - 25569) * 86400000);
+ ms := v mod 1000;
+ l := v div 1000;
+ p := localtime(@l);
+ Result := Int64(mktime(p)) * 1000 + ms;
+end;
+
+function JavaToDelphiDateTime(const dt: int64): TDateTime;
+var
+ p: ptm;
+ l, ms: Integer;
+begin
+ l := dt div 1000;
+ ms := dt mod 1000;
+ p := gmtime(@l);
+ Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms);
+end;
+{$ELSE}
+
+{$IFDEF WINDOWSNT_COMPATIBILITY}
+function DayLightCompareDate(const date: PSystemTime;
+ const compareDate: PSystemTime): Integer;
+var
+ limit_day, dayinsecs, weekofmonth: Integer;
+ First: Word;
+begin
+ if (date^.wMonth < compareDate^.wMonth) then
+ begin
+ Result := -1; (* We are in a month before the date limit. *)
+ Exit;
+ end;
+
+ if (date^.wMonth > compareDate^.wMonth) then
+ begin
+ Result := 1; (* We are in a month after the date limit. *)
+ Exit;
+ end;
+
+ (* if year is 0 then date is in day-of-week format, otherwise
+ * it's absolute date.
+ *)
+ if (compareDate^.wYear = 0) then
+ begin
+ (* compareDate.wDay is interpreted as number of the week in the month
+ * 5 means: the last week in the month *)
+ weekofmonth := compareDate^.wDay;
+ (* calculate the day of the first DayOfWeek in the month *)
+ First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1;
+ limit_day := First + 7 * (weekofmonth - 1);
+ (* check needed for the 5th weekday of the month *)
+ if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth - 1]) then
+ dec(limit_day, 7);
+ end
+ else
+ limit_day := compareDate^.wDay;
+
+ (* convert to seconds *)
+ limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60;
+ dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond;
+ (* and compare *)
+
+ if dayinsecs < limit_day then
+ Result := -1 else
+ if dayinsecs > limit_day then
+ Result := 1 else
+ Result := 0; (* date is equal to the date limit. *)
+end;
+
+function CompTimeZoneID(const pTZinfo: PTimeZoneInformation;
+ lpFileTime: PFileTime; islocal: Boolean): LongWord;
+var
+ ret: Integer;
+ beforeStandardDate, afterDaylightDate: Boolean;
+ llTime: Int64;
+ SysTime: TSystemTime;
+ ftTemp: TFileTime;
+begin
+ llTime := 0;
+
+ if (pTZinfo^.DaylightDate.wMonth <> 0) then
+ begin
+ (* if year is 0 then date is in day-of-week format, otherwise
+ * it's absolute date.
+ *)
+ if ((pTZinfo^.StandardDate.wMonth = 0) or
+ ((pTZinfo^.StandardDate.wYear = 0) and
+ ((pTZinfo^.StandardDate.wDay < 1) or
+ (pTZinfo^.StandardDate.wDay > 5) or
+ (pTZinfo^.DaylightDate.wDay < 1) or
+ (pTZinfo^.DaylightDate.wDay > 5)))) then
+ begin
+ SetLastError(ERROR_INVALID_PARAMETER);
+ Result := TIME_ZONE_ID_INVALID;
+ Exit;
+ end;
+
+ if (not islocal) then
+ begin
+ llTime := PInt64(lpFileTime)^;
+ dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000);
+ PInt64(@ftTemp)^ := llTime;
+ lpFileTime := @ftTemp;
+ end;
+
+ FileTimeToSystemTime(lpFileTime^, SysTime);
+
+ (* check for daylight savings *)
+ ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate);
+ if (ret = -2) then
+ begin
+ Result := TIME_ZONE_ID_INVALID;
+ Exit;
+ end;
+
+ beforeStandardDate := ret < 0;
+
+ if (not islocal) then
+ begin
+ dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000);
+ PInt64(@ftTemp)^ := llTime;
+ FileTimeToSystemTime(lpFileTime^, SysTime);
+ end;
+
+ ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate);
+ if (ret = -2) then
+ begin
+ Result := TIME_ZONE_ID_INVALID;
+ Exit;
+ end;
+
+ afterDaylightDate := ret >= 0;
+
+ Result := TIME_ZONE_ID_STANDARD;
+ if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then
+ begin
+ (* Northern hemisphere *)
+ if( beforeStandardDate and afterDaylightDate) then
+ Result := TIME_ZONE_ID_DAYLIGHT;
+ end else (* Down south *)
+ if( beforeStandardDate or afterDaylightDate) then
+ Result := TIME_ZONE_ID_DAYLIGHT;
+ end else
+ (* No transition date *)
+ Result := TIME_ZONE_ID_UNKNOWN;
+end;
+
+function GetTimezoneBias(const pTZinfo: PTimeZoneInformation;
+ lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean;
+var
+ bias: LongInt;
+ tzid: LongWord;
+begin
+ bias := pTZinfo^.Bias;
+ tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal);
+
+ if( tzid = TIME_ZONE_ID_INVALID) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ if (tzid = TIME_ZONE_ID_DAYLIGHT) then
+ inc(bias, pTZinfo^.DaylightBias)
+ else if (tzid = TIME_ZONE_ID_STANDARD) then
+ inc(bias, pTZinfo^.StandardBias);
+ pBias^ := bias;
+ Result := True;
+end;
+
+function SystemTimeToTzSpecificLocalTime(
+ lpTimeZoneInformation: PTimeZoneInformation;
+ lpUniversalTime, lpLocalTime: PSystemTime): BOOL;
+var
+ ft: TFileTime;
+ lBias: LongInt;
+ llTime: Int64;
+ tzinfo: TTimeZoneInformation;
+begin
+ if (lpTimeZoneInformation <> nil) then
+ tzinfo := lpTimeZoneInformation^ else
+ if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
+ begin
+ Result := False;
+ Exit;
+ end;
+
+ if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ llTime := PInt64(@ft)^;
+ if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ (* convert minutes to 100-nanoseconds-ticks *)
+ dec(llTime, Int64(lBias) * 600000000);
+ PInt64(@ft)^ := llTime;
+ Result := FileTimeToSystemTime(ft, lpLocalTime^);
+end;
+
+function TzSpecificLocalTimeToSystemTime(
+ const lpTimeZoneInformation: PTimeZoneInformation;
+ const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL;
+var
+ ft: TFileTime;
+ lBias: LongInt;
+ t: Int64;
+ tzinfo: TTimeZoneInformation;
+begin
+ if (lpTimeZoneInformation <> nil) then
+ tzinfo := lpTimeZoneInformation^
+ else
+ if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then
+ begin
+ Result := False;
+ Exit;
+ end;
+
+ if (not SystemTimeToFileTime(lpLocalTime^, ft)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ t := PInt64(@ft)^;
+ if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ (* convert minutes to 100-nanoseconds-ticks *)
+ inc(t, Int64(lBias) * 600000000);
+ PInt64(@ft)^ := t;
+ Result := FileTimeToSystemTime(ft, lpUniversalTime^);
+end;
+{$ELSE}
+function TzSpecificLocalTimeToSystemTime(
+ lpTimeZoneInformation: PTimeZoneInformation;
+ lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
+
+function SystemTimeToTzSpecificLocalTime(
+ lpTimeZoneInformation: PTimeZoneInformation;
+ lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll';
+{$ENDIF}
+
+function JavaToDelphiDateTime(const dt: int64): TDateTime;
+var
+ t: TSystemTime;
+begin
+ DateTimeToSystemTime(25569 + (dt / 86400000), t);
+ SystemTimeToTzSpecificLocalTime(nil, @t, @t);
+ Result := SystemTimeToDateTime(t);
+end;
+
+function DelphiToJavaDateTime(const dt: TDateTime): int64;
+var
+ t: TSystemTime;
+begin
+ DateTimeToSystemTime(dt, t);
+ TzSpecificLocalTimeToSystemTime(nil, @t, @t);
+ Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000)
+end;
+{$ENDIF}
+
+
+function SO(const s: SOString): ISuperObject; overload;
+begin
+ Result := TSuperObject.ParseString(PSOChar(s), False);
+end;
+
+function SA(const Args: array of const): ISuperObject; overload;
+type
+ TByteArray = array[0..sizeof(integer) - 1] of byte;
+ PByteArray = ^TByteArray;
+var
+ j: Integer;
+ intf: IInterface;
+begin
+ Result := TSuperObject.Create(stArray);
+ for j := 0 to length(Args) - 1 do
+ with Result.AsArray do
+ case TVarRec(Args[j]).VType of
+ vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger));
+ vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^));
+ vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean));
+ vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar)));
+ vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar)));
+ vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^));
+ vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^));
+ vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^)));
+ vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^)));
+ vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString))));
+ vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString))));
+ vtInterface:
+ if TVarRec(Args[j]).VInterface = nil then
+ Add(nil) else
+ if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then
+ Add(ISuperObject(intf)) else
+ Add(nil);
+ vtPointer :
+ if TVarRec(Args[j]).VPointer = nil then
+ Add(nil) else
+ Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
+ vtVariant:
+ Add(SO(TVarRec(Args[j]).VVariant^));
+ vtObject:
+ if TVarRec(Args[j]).VPointer = nil then
+ Add(nil) else
+ Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
+ vtClass:
+ if TVarRec(Args[j]).VPointer = nil then
+ Add(nil) else
+ Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer)));
+{$if declared(vtUnicodeString)}
+ vtUnicodeString:
+ Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString))));
+{$ifend}
+ else
+ assert(false);
+ end;
+end;
+
+function SO(const Args: array of const): ISuperObject; overload;
+var
+ j: Integer;
+ arr: ISuperObject;
+begin
+ Result := TSuperObject.Create(stObject);
+ arr := SA(Args);
+ with arr.AsArray do
+ for j := 0 to (Length div 2) - 1 do
+ Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]);
+end;
+
+function SO(const value: Variant): ISuperObject; overload;
+begin
+ with TVarData(value) do
+ case VType of
+ varNull: Result := nil;
+ varEmpty: Result := nil;
+ varSmallInt: Result := TSuperObject.Create(VSmallInt);
+ varInteger: Result := TSuperObject.Create(VInteger);
+ varSingle: Result := TSuperObject.Create(VSingle);
+ varDouble: Result := TSuperObject.Create(VDouble);
+ varCurrency: Result := TSuperObject.CreateCurrency(VCurrency);
+ varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate));
+ varOleStr: Result := TSuperObject.Create(SOString(VOleStr));
+ varBoolean: Result := TSuperObject.Create(VBoolean);
+ varShortInt: Result := TSuperObject.Create(VShortInt);
+ varByte: Result := TSuperObject.Create(VByte);
+ varWord: Result := TSuperObject.Create(VWord);
+ varLongWord: Result := TSuperObject.Create(VLongWord);
+ varInt64: Result := TSuperObject.Create(VInt64);
+ varString: Result := TSuperObject.Create(SOString(AnsiString(VString)));
+{$if declared(varUString)}
+ varUString: Result := TSuperObject.Create(SOString(string(VUString)));
+{$ifend}
+ else
+ raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]);
+ end;
+end;
+
+function ObjectIsError(obj: TSuperObject): boolean;
+begin
+ Result := PtrUInt(obj) > PtrUInt(-4000);
+end;
+
+function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean;
+begin
+ if obj <> nil then
+ Result := typ = obj.DataType else
+ Result := typ = stNull;
+end;
+
+function ObjectGetType(const obj: ISuperObject): TSuperType;
+begin
+ if obj <> nil then
+ Result := obj.DataType else
+ Result := stNull;
+end;
+
+function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean;
+var
+ i: TSuperAvlEntry;
+begin
+ if ObjectIsType(obj, stObject) then
+ begin
+ F.Ite := TSuperAvlIterator.Create(obj.AsObject);
+ F.Ite.First;
+ i := F.Ite.GetIter;
+ if i <> nil then
+ begin
+ f.key := i.Name;
+ f.val := i.Value;
+ Result := true;
+ end else
+ Result := False;
+ end else
+ Result := False;
+end;
+
+function ObjectFindNext(var F: TSuperObjectIter): boolean;
+var
+ i: TSuperAvlEntry;
+begin
+ F.Ite.Next;
+ i := F.Ite.GetIter;
+ if i <> nil then
+ begin
+ f.key := i.FName;
+ f.val := i.Value;
+ Result := true;
+ end else
+ Result := False;
+end;
+
+procedure ObjectFindClose(var F: TSuperObjectIter);
+begin
+ F.Ite.Free;
+ F.val := nil;
+end;
+
+{$IFDEF VER210}
+
+function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+begin
+ Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0);
+end;
+
+function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+begin
+ Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble));
+end;
+
+function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject;
+var
+ g: TGUID;
+begin
+ value.ExtractRawData(@g);
+ Result := TSuperObject.Create(
+ format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x',
+ [g.D1, g.D2, g.D3,
+ g.D4[0], g.D4[1], g.D4[2],
+ g.D4[3], g.D4[4], g.D4[5],
+ g.D4[6], g.D4[7]])
+ );
+end;
+
+function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+var
+ o: ISuperObject;
+begin
+ case ObjectGetType(obj) of
+ stBoolean:
+ begin
+ TValueData(Value).FAsSLong := obj.AsInteger;
+ Result := True;
+ end;
+ stInt:
+ begin
+ TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0);
+ Result := True;
+ end;
+ stString:
+ begin
+ o := SO(obj.AsString);
+ if not ObjectIsType(o, stString) then
+ Result := serialfromboolean(ctx, SO(obj.AsString), Value) else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+end;
+
+function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+var
+ dt: TDateTime;
+begin
+ case ObjectGetType(obj) of
+ stInt:
+ begin
+ TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger);
+ Result := True;
+ end;
+ stString:
+ begin
+ if TryStrToDateTime(obj.AsString, dt) then
+ begin
+ TValueData(Value).FAsDouble := dt;
+ Result := True;
+ end else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+end;
+
+function UuidFromString(const s: PSOChar; Uuid: PGUID): Boolean;
+const
+ hex2bin: array[#0..#102] of short = (
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x00 *)
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x10 *)
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x20 *)
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, (* 0x30 *)
+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x40 *)
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, (* 0x50 *)
+ -1,10,11,12,13,14,15); (* 0x60 *)
+var
+ i: Integer;
+begin
+ if (strlen(s) <> 36) then Exit(False);
+
+ if ((s[8] <> '-') or (s[13] <> '-') or (s[18] <> '-') or (s[23] <> '-')) then
+ Exit(False);
+
+ for i := 0 to 35 do
+ begin
+ if not i in [8,13,18,23] then
+ if ((s[i] > 'f') or ((hex2bin[s[i]] = -1) and (s[i] <> ''))) then
+ Exit(False);
+ end;
+
+ 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
+ (hex2bin[s[4]] shl 12) or (hex2bin[s[5]] shl 8) or (hex2bin[s[6]] shl 4) or hex2bin[s[7]]);
+ uuid.D2 := (hex2bin[s[9]] shl 12) or (hex2bin[s[10]] shl 8) or (hex2bin[s[11]] shl 4) or hex2bin[s[12]];
+ uuid.D3 := (hex2bin[s[14]] shl 12) or (hex2bin[s[15]] shl 8) or (hex2bin[s[16]] shl 4) or hex2bin[s[17]];
+
+ uuid.D4[0] := (hex2bin[s[19]] shl 4) or hex2bin[s[20]];
+ uuid.D4[1] := (hex2bin[s[21]] shl 4) or hex2bin[s[22]];
+ uuid.D4[2] := (hex2bin[s[24]] shl 4) or hex2bin[s[25]];
+ uuid.D4[3] := (hex2bin[s[26]] shl 4) or hex2bin[s[27]];
+ uuid.D4[4] := (hex2bin[s[28]] shl 4) or hex2bin[s[29]];
+ uuid.D4[5] := (hex2bin[s[30]] shl 4) or hex2bin[s[31]];
+ uuid.D4[6] := (hex2bin[s[32]] shl 4) or hex2bin[s[33]];
+ uuid.D4[7] := (hex2bin[s[34]] shl 4) or hex2bin[s[35]];
+ Result := True;
+end;
+
+function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean;
+begin
+ case ObjectGetType(obj) of
+ stNull:
+ begin
+ FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0);
+ Result := True;
+ end;
+ stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData);
+ else
+ Result := False;
+ end;
+end;
+
+function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload;
+var
+ owned: Boolean;
+begin
+ if ctx = nil then
+ begin
+ ctx := TSuperRttiContext.Create;
+ owned := True;
+ end else
+ owned := False;
+ try
+ if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then
+ raise Exception.Create('Invalid method call');
+ finally
+ if owned then
+ ctx.Free;
+ end;
+end;
+
+function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload;
+begin
+ Result := SOInvoke(obj, method, so(params), ctx)
+end;
+
+function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue;
+ const method: string; const params: ISuperObject;
+ var Return: ISuperObject): TSuperInvokeResult;
+var
+ t: TRttiInstanceType;
+ m: TRttiMethod;
+ a: TArray;
+ ps: TArray;
+ v: TValue;
+ index: ISuperObject;
+
+ function GetParams: Boolean;
+ var
+ i: Integer;
+ begin
+ case ObjectGetType(params) of
+ stArray:
+ for i := 0 to Length(ps) - 1 do
+ if (pfOut in ps[i].Flags) then
+ TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
+ if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then
+ Exit(False);
+ stObject:
+ for i := 0 to Length(ps) - 1 do
+ if (pfOut in ps[i].Flags) then
+ TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else
+ if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then
+ Exit(False);
+ stNull: ;
+ else
+ Exit(False);
+ end;
+ Result := True;
+ end;
+
+ procedure SetParams;
+ var
+ i: Integer;
+ begin
+ case ObjectGetType(params) of
+ stArray:
+ for i := 0 to Length(ps) - 1 do
+ if (ps[i].Flags * [pfVar, pfOut]) <> [] then
+ params.AsArray[i] := ctx.ToJson(a[i], index);
+ stObject:
+ for i := 0 to Length(ps) - 1 do
+ if (ps[i].Flags * [pfVar, pfOut]) <> [] then
+ params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index);
+ end;
+ end;
+
+begin
+ Result := irSuccess;
+ index := SO;
+ case obj.Kind of
+ tkClass:
+ begin
+ t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType));
+ m := t.GetMethod(method);
+ if m = nil then Exit(irMethothodError);
+ ps := m.GetParameters;
+ SetLength(a, Length(ps));
+ if not GetParams then Exit(irParamError);
+ if m.IsClassMethod then
+ begin
+ v := m.Invoke(obj.AsObject.ClassType, a);
+ Return := ctx.ToJson(v, index);
+ SetParams;
+ end else
+ begin
+ v := m.Invoke(obj, a);
+ Return := ctx.ToJson(v, index);
+ SetParams;
+ end;
+ end;
+ tkClassRef:
+ begin
+ t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass));
+ m := t.GetMethod(method);
+ if m = nil then Exit(irMethothodError);
+ ps := m.GetParameters;
+ SetLength(a, Length(ps));
+
+ if not GetParams then Exit(irParamError);
+ if m.IsClassMethod then
+ begin
+ v := m.Invoke(obj, a);
+ Return := ctx.ToJson(v, index);
+ SetParams;
+ end else
+ Exit(irError);
+ end;
+ else
+ Exit(irError);
+ end;
+end;
+
+{$ENDIF}
+
+{ TSuperEnumerator }
+
+constructor TSuperEnumerator.Create(const obj: ISuperObject);
+begin
+ FObj := obj;
+ FCount := -1;
+ if ObjectIsType(FObj, stObject) then
+ FObjEnum := FObj.AsObject.GetEnumerator else
+ FObjEnum := nil;
+end;
+
+destructor TSuperEnumerator.Destroy;
+begin
+ if FObjEnum <> nil then
+ FObjEnum.Free;
+end;
+
+function TSuperEnumerator.MoveNext: Boolean;
+begin
+ case ObjectGetType(FObj) of
+ stObject: Result := FObjEnum.MoveNext;
+ stArray:
+ begin
+ inc(FCount);
+ if FCount < FObj.AsArray.Length then
+ Result := True else
+ Result := False;
+ end;
+ else
+ Result := false;
+ end;
+end;
+
+function TSuperEnumerator.GetCurrent: ISuperObject;
+begin
+ case ObjectGetType(FObj) of
+ stObject: Result := FObjEnum.Current.Value;
+ stArray: Result := FObj.AsArray.GetO(FCount);
+ else
+ Result := FObj;
+ end;
+end;
+
+{ TSuperObject }
+
+constructor TSuperObject.Create(jt: TSuperType);
+begin
+ inherited Create;
+{$IFDEF DEBUG}
+ InterlockedIncrement(debugcount);
+{$ENDIF}
+
+ FProcessing := false;
+ FDataPtr := nil;
+ FDataType := jt;
+ case FDataType of
+ stObject: FO.c_object := TSuperTableString.Create;
+ stArray: FO.c_array := TSuperArray.Create;
+ stString: FOString := '';
+ else
+ FO.c_object := nil;
+ end;
+end;
+
+constructor TSuperObject.Create(b: boolean);
+begin
+ Create(stBoolean);
+ FO.c_boolean := b;
+end;
+
+constructor TSuperObject.Create(i: SuperInt);
+begin
+ Create(stInt);
+ FO.c_int := i;
+end;
+
+constructor TSuperObject.Create(d: double);
+begin
+ Create(stDouble);
+ FO.c_double := d;
+end;
+
+constructor TSuperObject.CreateCurrency(c: Currency);
+begin
+ Create(stCurrency);
+ FO.c_currency := c;
+end;
+
+destructor TSuperObject.Destroy;
+begin
+{$IFDEF DEBUG}
+ InterlockedDecrement(debugcount);
+{$ENDIF}
+ case FDataType of
+ stObject: FO.c_object.Free;
+ stArray: FO.c_array.Free;
+ end;
+ inherited;
+end;
+
+function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer;
+function DoEscape(str: PSOChar; len: Integer): Integer;
+var
+ pos, start_offset: Integer;
+ c: SOChar;
+ buf: array[0..5] of SOChar;
+type
+ TByteChar = record
+ case integer of
+ 0: (a, b: Byte);
+ 1: (c: WideChar);
+ end;
+ begin
+ if str = nil then
+ begin
+ Result := 0;
+ exit;
+ end;
+ pos := 0; start_offset := 0;
+ with writer do
+ while pos < len do
+ begin
+ c := str[pos];
+ case c of
+ #8,#9,#10,#12,#13,'"','\','/':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+
+ if(c = #8) then Append(ESC_BS, 2)
+ else if (c = #9) then Append(ESC_TAB, 2)
+ else if (c = #10) then Append(ESC_LF, 2)
+ else if (c = #12) then Append(ESC_FF, 2)
+ else if (c = #13) then Append(ESC_CR, 2)
+ else if (c = '"') then Append(ESC_QUOT, 2)
+ else if (c = '\') then Append(ESC_SL, 2)
+ else if (c = '/') then Append(ESC_SR, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ else
+ if (SOIChar(c) > 255) then
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ buf[0] := '\';
+ buf[1] := 'u';
+ buf[2] := super_hex_chars[TByteChar(c).b shr 4];
+ buf[3] := super_hex_chars[TByteChar(c).b and $f];
+ buf[4] := super_hex_chars[TByteChar(c).a shr 4];
+ buf[5] := super_hex_chars[TByteChar(c).a and $f];
+ Append(@buf, 6);
+ inc(pos);
+ start_offset := pos;
+ end else
+ if (c < #32) or (c > #127) then
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ buf[0] := '\';
+ buf[1] := 'u';
+ buf[2] := '0';
+ buf[3] := '0';
+ buf[4] := super_hex_chars[ord(c) shr 4];
+ buf[5] := super_hex_chars[ord(c) and $f];
+ Append(buf, 6);
+ inc(pos);
+ start_offset := pos;
+ end else
+ inc(pos);
+ end;
+ end;
+ if(pos - start_offset > 0) then
+ writer.Append(str + start_offset, pos - start_offset);
+ Result := 0;
+ end;
+
+function DoMinimalEscape(str: PSOChar; len: Integer): Integer;
+var
+ pos, start_offset: Integer;
+ c: SOChar;
+type
+ TByteChar = record
+ case integer of
+ 0: (a, b: Byte);
+ 1: (c: WideChar);
+ end;
+ begin
+ if str = nil then
+ begin
+ Result := 0;
+ exit;
+ end;
+ pos := 0; start_offset := 0;
+ with writer do
+ while pos < len do
+ begin
+ c := str[pos];
+ case c of
+ #0:
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_ZERO, 6);
+ inc(pos);
+ start_offset := pos;
+ end;
+ '"':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_QUOT, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ '\':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_SL, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ '/':
+ begin
+ if(pos - start_offset > 0) then
+ Append(str + start_offset, pos - start_offset);
+ Append(ESC_SR, 2);
+ inc(pos);
+ start_offset := pos;
+ end;
+ else
+ inc(pos);
+ end;
+ end;
+ if(pos - start_offset > 0) then
+ writer.Append(str + start_offset, pos - start_offset);
+ Result := 0;
+ end;
+
+
+ procedure _indent(i: shortint; r: boolean);
+ begin
+ inc(level, i);
+ if r then
+ with writer do
+ begin
+{$IFDEF MSWINDOWS}
+ Append(TOK_CRLF, 2);
+{$ELSE}
+ Append(TOK_LF, 1);
+{$ENDIF}
+ for i := 0 to level - 1 do
+ Append(TOK_SP, 1);
+ end;
+ end;
+var
+ k,j: Integer;
+ iter: TSuperObjectIter;
+ st: AnsiString;
+ val: ISuperObject;
+ fbuffer: array[0..31] of AnsiChar;
+const
+ ENDSTR_A: PSOChar = '": ';
+ ENDSTR_B: PSOChar = '":';
+begin
+
+ if FProcessing then
+ begin
+ Result := writer.Append(TOK_NULL, 4);
+ Exit;
+ end;
+
+ FProcessing := true;
+ with writer do
+ try
+ case FDataType of
+ stObject:
+ if FO.c_object.FCount > 0 then
+ begin
+ k := 0;
+ Append(TOK_CBL, 1);
+ if indent then _indent(1, false);
+ if ObjectFindFirst(Self, iter) then
+ repeat
+ {$IFDEF SUPER_METHOD}
+ if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then
+ begin
+ {$ENDIF}
+ if (iter.val = nil) or (not iter.val.Processing) then
+ begin
+ if(k <> 0) then
+ Append(TOK_COM, 1);
+ if indent then _indent(0, true);
+ Append(TOK_DQT, 1);
+ if escape then
+ doEscape(PSOChar(iter.key), Length(iter.key)) else
+ DoMinimalEscape(PSOChar(iter.key), Length(iter.key));
+ if indent then
+ Append(ENDSTR_A, 3) else
+ Append(ENDSTR_B, 2);
+ if(iter.val = nil) then
+ Append(TOK_NULL, 4) else
+ iter.val.write(writer, indent, escape, level);
+ inc(k);
+ end;
+ {$IFDEF SUPER_METHOD}
+ end;
+ {$ENDIF}
+ until not ObjectFindNext(iter);
+ ObjectFindClose(iter);
+ if indent then _indent(-1, true);
+ Result := Append(TOK_CBR, 1);
+ end else
+ Result := Append(TOK_OBJ, 2);
+ stBoolean:
+ begin
+ if (FO.c_boolean) then
+ Result := Append(TOK_TRUE, 4) else
+ Result := Append(TOK_FALSE, 5);
+ end;
+ stInt:
+ begin
+ str(FO.c_int, st);
+ Result := Append(PSOChar(SOString(st)));
+ end;
+ stDouble:
+ Result := Append(PSOChar(SOString(gcvt(FO.c_double, 15, fbuffer))));
+ stCurrency:
+ begin
+ Result := Append(PSOChar(CurrToStr(FO.c_currency)));
+ end;
+ stString:
+ begin
+ Append(TOK_DQT, 1);
+ if escape then
+ doEscape(PSOChar(FOString), Length(FOString)) else
+ DoMinimalEscape(PSOChar(FOString), Length(FOString));
+ Append(TOK_DQT, 1);
+ Result := 0;
+ end;
+ stArray:
+ if FO.c_array.FLength > 0 then
+ begin
+ Append(TOK_ARL, 1);
+ if indent then _indent(1, true);
+ k := 0;
+ j := 0;
+ while k < FO.c_array.FLength do
+ begin
+
+ val := FO.c_array.GetO(k);
+ {$IFDEF SUPER_METHOD}
+ if not ObjectIsType(val, stMethod) then
+ begin
+ {$ENDIF}
+ if (val = nil) or (not val.Processing) then
+ begin
+ if (j <> 0) then
+ Append(TOK_COM, 1);
+ if(val = nil) then
+ Append(TOK_NULL, 4) else
+ val.write(writer, indent, escape, level);
+ inc(j);
+ end;
+ {$IFDEF SUPER_METHOD}
+ end;
+ {$ENDIF}
+ inc(k);
+ end;
+ if indent then _indent(-1, false);
+ Result := Append(TOK_ARR, 1);
+ end else
+ Result := Append(TOK_ARRAY, 2);
+ stNull:
+ Result := Append(TOK_NULL, 4);
+ else
+ Result := 0;
+ end;
+ finally
+ FProcessing := false;
+ end;
+end;
+
+function TSuperObject.IsType(AType: TSuperType): boolean;
+begin
+ Result := AType = FDataType;
+end;
+
+function TSuperObject.AsBoolean: boolean;
+begin
+ case FDataType of
+ stBoolean: Result := FO.c_boolean;
+ stInt: Result := (FO.c_int <> 0);
+ stDouble: Result := (FO.c_double <> 0);
+ stCurrency: Result := (FO.c_currency <> 0);
+ stString: Result := (Length(FOString) <> 0);
+ stNull: Result := False;
+ else
+ Result := True;
+ end;
+end;
+
+function TSuperObject.AsInteger: SuperInt;
+var
+ code: integer;
+ cint: SuperInt;
+begin
+ case FDataType of
+ stInt: Result := FO.c_int;
+ stDouble: Result := round(FO.c_double);
+ stCurrency: Result := round(FO.c_currency);
+ stBoolean: Result := ord(FO.c_boolean);
+ stString:
+ begin
+ Val(FOString, cint, code);
+ if code = 0 then
+ Result := cint else
+ Result := 0;
+ end;
+ else
+ Result := 0;
+ end;
+end;
+
+function TSuperObject.AsDouble: Double;
+var
+ code: integer;
+ cdouble: double;
+begin
+ case FDataType of
+ stDouble: Result := FO.c_double;
+ stCurrency: Result := FO.c_currency;
+ stInt: Result := FO.c_int;
+ stBoolean: Result := ord(FO.c_boolean);
+ stString:
+ begin
+ Val(FOString, cdouble, code);
+ if code = 0 then
+ Result := cdouble else
+ Result := 0.0;
+ end;
+ else
+ Result := 0.0;
+ end;
+end;
+
+function TSuperObject.AsCurrency: Currency;
+var
+ code: integer;
+ cdouble: double;
+begin
+ case FDataType of
+ stDouble: Result := FO.c_double;
+ stCurrency: Result := FO.c_currency;
+ stInt: Result := FO.c_int;
+ stBoolean: Result := ord(FO.c_boolean);
+ stString:
+ begin
+ Val(FOString, cdouble, code);
+ if code = 0 then
+ Result := cdouble else
+ Result := 0.0;
+ end;
+ else
+ Result := 0.0;
+ end;
+end;
+
+function TSuperObject.AsString: SOString;
+begin
+ if FDataType = stString then
+ Result := FOString else
+ Result := AsJSon(false, false);
+end;
+
+function TSuperObject.GetEnumerator: TSuperEnumerator;
+begin
+ Result := TSuperEnumerator.Create(Self);
+end;
+
+procedure TSuperObject.AfterConstruction;
+begin
+ InterlockedDecrement(FRefCount);
+end;
+
+procedure TSuperObject.BeforeDestruction;
+begin
+ if RefCount <> 0 then
+ raise Exception.Create('Invalid pointer');
+end;
+
+function TSuperObject.AsArray: TSuperArray;
+begin
+ if FDataType = stArray then
+ Result := FO.c_array else
+ Result := nil;
+end;
+
+function TSuperObject.AsObject: TSuperTableString;
+begin
+ if FDataType = stObject then
+ Result := FO.c_object else
+ Result := nil;
+end;
+
+function TSuperObject.AsJSon(indent, escape: boolean): SOString;
+var
+ pb: TSuperWriterString;
+begin
+ pb := TSuperWriterString.Create;
+ try
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ Result := '';
+ Exit;
+ end;
+ if pb.FBPos > 0 then
+ Result := pb.FBuf else
+ Result := '';
+ finally
+ pb.Free;
+ end;
+end;
+
+class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject;
+ options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
+var
+ tok: TSuperTokenizer;
+ obj: ISuperObject;
+begin
+ tok := TSuperTokenizer.Create;
+ obj := ParseEx(tok, s, -1, strict, this, options, put, dt);
+ if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then
+ Result := nil else
+ Result := obj;
+ tok.Free;
+end;
+
+class function TSuperObject.ParseStream(stream: TStream; strict: Boolean;
+ partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
+ const put: ISuperObject; dt: TSuperType): ISuperObject;
+const
+ BUFFER_SIZE = 1024;
+var
+ tok: TSuperTokenizer;
+ buffera: array[0..BUFFER_SIZE-1] of AnsiChar;
+ bufferw: array[0..BUFFER_SIZE-1] of SOChar;
+ bom: array[0..1] of byte;
+ unicode: boolean;
+ j, size: Integer;
+ st: string;
+begin
+ st := '';
+ tok := TSuperTokenizer.Create;
+
+ if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then
+ begin
+ unicode := true;
+ size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
+ end else
+ begin
+ unicode := false;
+ stream.Seek(0, soFromBeginning);
+ size := stream.Read(buffera, BUFFER_SIZE);
+ end;
+
+ while size > 0 do
+ begin
+ if not unicode then
+ for j := 0 to size - 1 do
+ bufferw[j] := SOChar(buffera[j]);
+ ParseEx(tok, bufferw, size, strict, this, options, put, dt);
+
+ if tok.err = teContinue then
+ begin
+ if not unicode then
+ size := stream.Read(buffera, BUFFER_SIZE) else
+ size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar);
+ end else
+ Break;
+ end;
+ if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then
+ Result := nil else
+ Result := tok.stack[tok.depth].current;
+ tok.Free;
+end;
+
+class function TSuperObject.ParseFile(const FileName: string; strict: Boolean;
+ partial: boolean; const this: ISuperObject; options: TSuperFindOptions;
+ const put: ISuperObject; dt: TSuperType): ISuperObject;
+var
+ stream: TFileStream;
+begin
+ stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite);
+ try
+ Result := ParseStream(stream, strict, partial, this, options, put, dt);
+ finally
+ stream.Free;
+ end;
+end;
+
+class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer;
+ strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject;
+
+const
+ spaces = [#32,#8,#9,#10,#12,#13];
+ delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0];
+ reserved = delimiters + spaces;
+ path = ['a'..'z', 'A'..'Z', '.', '_'];
+
+ function hexdigit(x: SOChar): byte;
+ begin
+ if x <= '9' then
+ Result := byte(x) - byte('0') else
+ Result := (byte(x) and 7) + 9;
+ end;
+ function min(v1, v2: integer): integer; begin if v1 < v2 then result := v1 else result := v2 end;
+
+var
+ obj: ISuperObject;
+ v: SOChar;
+{$IFDEF SUPER_METHOD}
+ sm: TSuperMethod;
+{$ENDIF}
+ numi: SuperInt;
+ numd: Double;
+ code: integer;
+ TokRec: PSuperTokenerSrec;
+ evalstack: integer;
+ p: PSOChar;
+
+ function IsEndDelimiter(v: AnsiChar): Boolean;
+ begin
+ if tok.depth > 0 then
+ case tok.stack[tok.depth - 1].state of
+ tsArrayAdd: Result := v in [',', ']', #0];
+ tsObjectValueAdd: Result := v in [',', '}', #0];
+ else
+ Result := v = #0;
+ end else
+ Result := v = #0;
+ end;
+
+label out, redo_char;
+begin
+ evalstack := 0;
+ obj := nil;
+ Result := nil;
+ TokRec := @tok.stack[tok.depth];
+
+ tok.char_offset := 0;
+ tok.err := teSuccess;
+
+ repeat
+ if (tok.char_offset = len) then
+ begin
+ if (tok.depth = 0) and (TokRec^.state = tsEatws) and
+ (TokRec^.saved_state = tsFinish) then
+ tok.err := teSuccess else
+ tok.err := teContinue;
+ goto out;
+ end;
+
+ v := str^;
+
+ case v of
+ #10:
+ begin
+ inc(tok.line);
+ tok.col := 0;
+ end;
+ #9: inc(tok.col, 4);
+ else
+ inc(tok.col);
+ end;
+
+redo_char:
+ case TokRec^.state of
+ tsEatws:
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else
+ if (v = '/') then
+ begin
+ tok.pb.Reset;
+ tok.pb.Append(@v, 1);
+ TokRec^.state := tsCommentStart;
+ end else begin
+ TokRec^.state := TokRec^.saved_state;
+ goto redo_char;
+ end
+ end;
+
+ tsStart:
+ case v of
+ '"',
+ '''':
+ begin
+ TokRec^.state := tsString;
+ tok.pb.Reset;
+ tok.quote_char := v;
+ end;
+ '-':
+ begin
+ TokRec^.state := tsNumber;
+ tok.pb.Reset;
+ tok.is_double := 0;
+ tok.floatcount := -1;
+ goto redo_char;
+ end;
+
+ '0'..'9':
+ begin
+ if (tok.depth = 0) then
+ case ObjectGetType(this) of
+ stObject:
+ begin
+ TokRec^.state := tsIdentifier;
+ TokRec^.current := this;
+ goto redo_char;
+ end;
+ end;
+ TokRec^.state := tsNumber;
+ tok.pb.Reset;
+ tok.is_double := 0;
+ tok.floatcount := -1;
+ goto redo_char;
+ end;
+ '{':
+ begin
+ TokRec^.state := tsEatws;
+ TokRec^.saved_state := tsObjectFieldStart;
+ TokRec^.current := TSuperObject.Create(stObject);
+ end;
+ '[':
+ begin
+ TokRec^.state := tsEatws;
+ TokRec^.saved_state := tsArray;
+ TokRec^.current := TSuperObject.Create(stArray);
+ end;
+{$IFDEF SUPER_METHOD}
+ '(':
+ begin
+ if (tok.depth = 0) and ObjectIsType(this, stMethod) then
+ begin
+ TokRec^.current := this;
+ TokRec^.state := tsParamValue;
+ end;
+ end;
+{$ENDIF}
+ 'N',
+ 'n':
+ begin
+ TokRec^.state := tsNull;
+ tok.pb.Reset;
+ tok.st_pos := 0;
+ goto redo_char;
+ end;
+ 'T',
+ 't',
+ 'F',
+ 'f':
+ begin
+ TokRec^.state := tsBoolean;
+ tok.pb.Reset;
+ tok.st_pos := 0;
+ goto redo_char;
+ end;
+ else
+ TokRec^.state := tsIdentifier;
+ tok.pb.Reset;
+ goto redo_char;
+ end;
+
+ tsFinish:
+ begin
+ if(tok.depth = 0) then goto out;
+ obj := TokRec^.current;
+ tok.ResetLevel(tok.depth);
+ dec(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+
+ tsNull:
+ begin
+ tok.pb.Append(@v, 1);
+ if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
+ begin
+ if (tok.st_pos = 4) then
+ if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
+ TokRec^.state := tsIdentifier else
+ begin
+ TokRec^.current := TSuperObject.Create(stNull);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end;
+ end else
+ begin
+ TokRec^.state := tsIdentifier;
+ tok.pb.FBuf[tok.st_pos] := #0;
+ dec(tok.pb.FBPos);
+ goto redo_char;
+ end;
+ inc(tok.st_pos);
+ end;
+
+ tsCommentStart:
+ begin
+ if(v = '*') then
+ begin
+ TokRec^.state := tsComment;
+ end else
+ if (v = '/') then
+ begin
+ TokRec^.state := tsCommentEol;
+ end else
+ begin
+ tok.err := teParseComment;
+ goto out;
+ end;
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsComment:
+ begin
+ if(v = '*') then
+ TokRec^.state := tsCommentEnd;
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsCommentEol:
+ begin
+ if (v = #10) then
+ TokRec^.state := tsEatws else
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsCommentEnd:
+ begin
+ tok.pb.Append(@v, 1);
+ if (v = '/') then
+ TokRec^.state := tsEatws else
+ TokRec^.state := tsComment;
+ end;
+
+ tsString:
+ begin
+ if (v = tok.quote_char) then
+ begin
+ TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString));
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsString;
+ TokRec^.state := tsStringEscape;
+ end else
+ begin
+ tok.pb.Append(@v, 1);
+ end
+ end;
+
+ tsEvalProperty:
+ begin
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stObject);
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
+ end else
+ if not ObjectIsType(TokRec^.current, stObject) then
+ begin
+ tok.err := teEvalObject;
+ goto out;
+ end;
+ tok.pb.Reset;
+ TokRec^.state := tsIdentifier;
+ goto redo_char;
+ end;
+
+ tsEvalArray:
+ begin
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stArray);
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current)
+ end else
+ if not ObjectIsType(TokRec^.current, stArray) then
+ begin
+ tok.err := teEvalArray;
+ goto out;
+ end;
+ tok.pb.Reset;
+ TokRec^.state := tsParamValue;
+ goto redo_char;
+ end;
+{$IFDEF SUPER_METHOD}
+ tsEvalMethod:
+ begin
+ if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
+ begin
+ tok.pb.Reset;
+ TokRec^.obj := TSuperObject.Create(stArray);
+ TokRec^.state := tsMethodValue;
+ goto redo_char;
+ end else
+ begin
+ tok.err := teEvalMethod;
+ goto out;
+ end;
+ end;
+
+ tsMethodValue:
+ begin
+ case v of
+ ')':
+ TokRec^.state := tsIdentifier;
+ else
+ if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ inc(evalstack);
+ TokRec^.state := tsMethodPut;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+ end;
+
+ tsMethodPut:
+ begin
+ TokRec^.obj.AsArray.Add(obj);
+ case v of
+ ',':
+ begin
+ tok.pb.Reset;
+ TokRec^.saved_state := tsMethodValue;
+ TokRec^.state := tsEatws;
+ end;
+ ')':
+ begin
+ if TokRec^.obj.AsArray.Length = 1 then
+ TokRec^.obj := TokRec^.obj.AsArray.GetO(0);
+ dec(evalstack);
+ tok.pb.Reset;
+ TokRec^.saved_state := tsIdentifier;
+ TokRec^.state := tsEatws;
+ end;
+ else
+ tok.err := teEvalMethod;
+ goto out;
+ end;
+ end;
+{$ENDIF}
+ tsParamValue:
+ begin
+ case v of
+ ']':
+ TokRec^.state := tsIdentifier;
+ else
+ if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ inc(evalstack);
+ TokRec^.state := tsParamPut;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+ end;
+
+ tsParamPut:
+ begin
+ dec(evalstack);
+ TokRec^.obj := obj;
+ tok.pb.Reset;
+ TokRec^.saved_state := tsIdentifier;
+ TokRec^.state := tsEatws;
+ if v <> ']' then
+ begin
+ tok.err := teEvalArray;
+ goto out;
+ end;
+ end;
+
+ tsIdentifier:
+ begin
+ if (this = nil) then
+ begin
+ if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then
+ begin
+ if not strict then
+ begin
+ tok.pb.TrimRight;
+ TokRec^.current := TSuperObject.Create(tok.pb.Fbuf);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end else
+ begin
+ tok.err := teParseString;
+ goto out;
+ end;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsIdentifier;
+ TokRec^.state := tsStringEscape;
+ end else
+ tok.pb.Append(@v, 1);
+ end else
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then
+ begin
+ TokRec^.gparent := TokRec^.parent;
+ if TokRec^.current = nil then
+ TokRec^.parent := this else
+ TokRec^.parent := TokRec^.current;
+
+ case ObjectGetType(TokRec^.parent) of
+ stObject:
+ case v of
+ '.':
+ begin
+ TokRec^.state := tsEvalProperty;
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ end;
+ '[':
+ begin
+ TokRec^.state := tsEvalArray;
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ end;
+ '(':
+ begin
+ TokRec^.state := tsEvalMethod;
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ end;
+ else
+ if tok.pb.FBPos > 0 then
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put);
+ TokRec^.current := put
+ end else
+ if (foDelete in options) and (evalstack = 0) then
+ begin
+ TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf);
+ end else
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(dt);
+ TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current);
+ end;
+ TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf);
+ TokRec^.state := tsFinish;
+ goto redo_char;
+ end;
+ stArray:
+ begin
+ if TokRec^.obj <> nil then
+ begin
+ if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then
+ begin
+ tok.err := teEvalInt;
+ TokRec^.obj := nil;
+ goto out;
+ end;
+ numi := TokRec^.obj.AsInteger;
+ TokRec^.obj := nil;
+
+ TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
+ case v of
+ '.':
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stObject);
+ TokRec^.parent.AsArray.PutO(numi, TokRec^.current);
+ end else
+ if (TokRec^.current = nil) then
+ begin
+ tok.err := teEvalObject;
+ goto out;
+ end;
+ '[':
+ begin
+ if (TokRec^.current = nil) and (foCreatePath in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stArray);
+ TokRec^.parent.AsArray.Add(TokRec^.current);
+ end else
+ if (TokRec^.current = nil) then
+ begin
+ tok.err := teEvalArray;
+ goto out;
+ end;
+ TokRec^.state := tsEvalArray;
+ end;
+ '(': TokRec^.state := tsEvalMethod;
+ else
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ TokRec^.parent.AsArray.PutO(numi, put);
+ TokRec^.current := put;
+ end else
+ if (foDelete in options) and (evalstack = 0) then
+ begin
+ TokRec^.current := TokRec^.parent.AsArray.Delete(numi);
+ end else
+ TokRec^.current := TokRec^.parent.AsArray.GetO(numi);
+ TokRec^.state := tsFinish;
+ goto redo_char
+ end;
+ end else
+ begin
+ case v of
+ '.':
+ begin
+ if (foPutValue in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stObject);
+ TokRec^.parent.AsArray.Add(TokRec^.current);
+ end else
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
+ end;
+ '[':
+ begin
+ if (foPutValue in options) then
+ begin
+ TokRec^.current := TSuperObject.Create(stArray);
+ TokRec^.parent.AsArray.Add(TokRec^.current);
+ end else
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
+ TokRec^.state := tsEvalArray;
+ end;
+ '(':
+ begin
+ if not (foPutValue in options) then
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else
+ TokRec^.current := nil;
+
+ TokRec^.state := tsEvalMethod;
+ end;
+ else
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ TokRec^.parent.AsArray.Add(put);
+ TokRec^.current := put;
+ end else
+ if tok.pb.FBPos = 0 then
+ TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1);
+ TokRec^.state := tsFinish;
+ goto redo_char
+ end;
+ end;
+ end;
+{$IFDEF SUPER_METHOD}
+ stMethod:
+ case v of
+ '.':
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.obj := nil;
+ end;
+ '[':
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.state := tsEvalArray;
+ TokRec^.obj := nil;
+ end;
+ '(':
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.state := tsEvalMethod;
+ TokRec^.obj := nil;
+ end;
+ else
+ if not (foPutValue in options) or (evalstack > 0) then
+ begin
+ TokRec^.current := nil;
+ sm := TokRec^.parent.AsMethod;
+ sm(TokRec^.gparent, TokRec^.obj, TokRec^.current);
+ TokRec^.obj := nil;
+ TokRec^.state := tsFinish;
+ goto redo_char
+ end else
+ begin
+ tok.err := teEvalMethod;
+ TokRec^.obj := nil;
+ goto out;
+ end;
+ end;
+{$ENDIF}
+ end;
+ end else
+ tok.pb.Append(@v, 1);
+ end;
+ end;
+
+ tsStringEscape:
+ case v of
+ 'b',
+ 'n',
+ 'r',
+ 't',
+ 'f':
+ begin
+ if(v = 'b') then tok.pb.Append(TOK_BS, 1)
+ else if(v = 'n') then tok.pb.Append(TOK_LF, 1)
+ else if(v = 'r') then tok.pb.Append(TOK_CR, 1)
+ else if(v = 't') then tok.pb.Append(TOK_TAB, 1)
+ else if(v = 'f') then tok.pb.Append(TOK_FF, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end;
+ 'u':
+ begin
+ tok.ucs_char := 0;
+ tok.st_pos := 0;
+ TokRec^.state := tsEscapeUnicode;
+ end;
+ 'x':
+ begin
+ tok.ucs_char := 0;
+ tok.st_pos := 0;
+ TokRec^.state := tsEscapeHexadecimal;
+ end
+ else
+ tok.pb.Append(@v, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end;
+
+ tsEscapeUnicode:
+ begin
+ if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
+ begin
+ inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4)));
+ inc(tok.st_pos);
+ if (tok.st_pos = 4) then
+ begin
+ tok.pb.Append(@tok.ucs_char, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end
+ end else
+ begin
+ tok.err := teParseString;
+ goto out;
+ end
+ end;
+ tsEscapeHexadecimal:
+ begin
+ if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then
+ begin
+ inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4)));
+ inc(tok.st_pos);
+ if (tok.st_pos = 2) then
+ begin
+ tok.pb.Append(@tok.ucs_char, 1);
+ TokRec^.state := TokRec^.saved_state;
+ end
+ end else
+ begin
+ tok.err := teParseString;
+ goto out;
+ end
+ end;
+ tsBoolean:
+ begin
+ tok.pb.Append(@v, 1);
+ if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then
+ begin
+ if (tok.st_pos = 4) then
+ if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
+ TokRec^.state := tsIdentifier else
+ begin
+ TokRec^.current := TSuperObject.Create(true);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end
+ end else
+ if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then
+ begin
+ if (tok.st_pos = 5) then
+ if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then
+ TokRec^.state := tsIdentifier else
+ begin
+ TokRec^.current := TSuperObject.Create(false);
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end
+ end else
+ begin
+ TokRec^.state := tsIdentifier;
+ tok.pb.FBuf[tok.st_pos] := #0;
+ dec(tok.pb.FBPos);
+ goto redo_char;
+ end;
+ inc(tok.st_pos);
+ end;
+
+ tsNumber:
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then
+ begin
+ tok.pb.Append(@v, 1);
+ if (SOIChar(v) < 256) then
+ case v of
+ '.': begin
+ tok.is_double := 1;
+ tok.floatcount := 0;
+ end;
+ 'e','E':
+ begin
+ tok.is_double := 1;
+ tok.floatcount := -1;
+ end;
+ '0'..'9':
+ begin
+
+ if (tok.is_double = 1) and (tok.floatcount >= 0) then
+ begin
+ inc(tok.floatcount);
+ if tok.floatcount > 4 then
+ tok.floatcount := -1;
+ end;
+ end;
+ end;
+ end else
+ begin
+ if (tok.is_double = 0) then
+ begin
+ val(tok.pb.FBuf, numi, code);
+ if ObjectIsType(this, stArray) then
+ begin
+ if (foPutValue in options) and (evalstack = 0) then
+ begin
+ this.AsArray.PutO(numi, put);
+ TokRec^.current := put;
+ end else
+ if (foDelete in options) and (evalstack = 0) then
+ TokRec^.current := this.AsArray.Delete(numi) else
+ TokRec^.current := this.AsArray.GetO(numi);
+ end else
+ TokRec^.current := TSuperObject.Create(numi);
+
+ end else
+ if (tok.is_double <> 0) then
+ begin
+ if tok.floatcount >= 0 then
+ begin
+ p := tok.pb.FBuf;
+ while p^ <> '.' do inc(p);
+ for code := 0 to tok.floatcount - 1 do
+ begin
+ p^ := p[1];
+ inc(p);
+ end;
+ p^ := #0;
+ val(tok.pb.FBuf, numi, code);
+ case tok.floatcount of
+ 0: numi := numi * 10000;
+ 1: numi := numi * 1000;
+ 2: numi := numi * 100;
+ 3: numi := numi * 10;
+ end;
+ TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^);
+ end else
+ begin
+ val(tok.pb.FBuf, numd, code);
+ TokRec^.current := TSuperObject.Create(numd);
+ end;
+ end else
+ begin
+ tok.err := teParseNumber;
+ goto out;
+ end;
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end
+ end;
+
+ tsArray:
+ begin
+ if (v = ']') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ TokRec^.state := tsArrayAdd;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end
+ end;
+
+ tsArrayAdd:
+ begin
+ TokRec^.current.AsArray.Add(obj);
+ TokRec^.saved_state := tsArraySep;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end;
+
+ tsArraySep:
+ begin
+ if (v = ']') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = ',') then
+ begin
+ TokRec^.saved_state := tsArray;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ tok.err := teParseArray;
+ goto out;
+ end
+ end;
+
+ tsObjectFieldStart:
+ begin
+ if (v = '}') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then
+ begin
+ tok.quote_char := v;
+ tok.pb.Reset;
+ TokRec^.state := tsObjectField;
+ end else
+ if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then
+ begin
+ TokRec^.state := tsObjectUnquotedField;
+ tok.pb.Reset;
+ goto redo_char;
+ end else
+ begin
+ tok.err := teParseObjectKeyName;
+ goto out;
+ end
+ end;
+
+ tsObjectField:
+ begin
+ if (v = tok.quote_char) then
+ begin
+ TokRec^.field_name := tok.pb.FBuf;
+ TokRec^.saved_state := tsObjectFieldEnd;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsObjectField;
+ TokRec^.state := tsStringEscape;
+ end else
+ begin
+ tok.pb.Append(@v, 1);
+ end
+ end;
+
+ tsObjectUnquotedField:
+ begin
+ if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then
+ begin
+ TokRec^.field_name := tok.pb.FBuf;
+ TokRec^.saved_state := tsObjectFieldEnd;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end else
+ if (v = '\') then
+ begin
+ TokRec^.saved_state := tsObjectUnquotedField;
+ TokRec^.state := tsStringEscape;
+ end else
+ tok.pb.Append(@v, 1);
+ end;
+
+ tsObjectFieldEnd:
+ begin
+ if (v = ':') then
+ begin
+ TokRec^.saved_state := tsObjectValue;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ tok.err := teParseObjectKeySep;
+ goto out;
+ end
+ end;
+
+ tsObjectValue:
+ begin
+ if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then
+ begin
+ tok.err := teDepth;
+ goto out;
+ end;
+ TokRec^.state := tsObjectValueAdd;
+ inc(tok.depth);
+ tok.ResetLevel(tok.depth);
+ TokRec := @tok.stack[tok.depth];
+ goto redo_char;
+ end;
+
+ tsObjectValueAdd:
+ begin
+ TokRec^.current.AsObject.PutO(TokRec^.field_name, obj);
+ TokRec^.field_name := '';
+ TokRec^.saved_state := tsObjectSep;
+ TokRec^.state := tsEatws;
+ goto redo_char;
+ end;
+
+ tsObjectSep:
+ begin
+ if (v = '}') then
+ begin
+ TokRec^.saved_state := tsFinish;
+ TokRec^.state := tsEatws;
+ end else
+ if (v = ',') then
+ begin
+ TokRec^.saved_state := tsObjectFieldStart;
+ TokRec^.state := tsEatws;
+ end else
+ begin
+ tok.err := teParseObjectValueSep;
+ goto out;
+ end
+ end;
+ end;
+ inc(str);
+ inc(tok.char_offset);
+ until v = #0;
+
+ if(TokRec^.state <> tsFinish) and
+ (TokRec^.saved_state <> tsFinish) then
+ tok.err := teParseEof;
+
+ out:
+ if(tok.err in [teSuccess]) then
+ begin
+{$IFDEF SUPER_METHOD}
+ if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then
+ begin
+ sm := TokRec^.current.AsMethod;
+ sm(TokRec^.parent, put, Result);
+ end else
+{$ENDIF}
+ Result := TokRec^.current;
+ end else
+ Result := nil;
+end;
+
+procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value);
+end;
+
+procedure TSuperObject.PutB(const path: SOString; Value: Boolean);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+procedure TSuperObject.PutD(const path: SOString; Value: Double);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+procedure TSuperObject.PutC(const path: SOString; Value: Currency);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value));
+end;
+
+procedure TSuperObject.PutI(const path: SOString; Value: SuperInt);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+procedure TSuperObject.PutS(const path: SOString; const Value: SOString);
+begin
+ ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+
+function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+begin
+ if GetInterface(IID, Obj) then
+ Result := 0
+ else
+ Result := E_NOINTERFACE;
+end;
+
+function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer;
+var
+ pb: TSuperWriterStream;
+begin
+ if escape then
+ pb := TSuperAnsiWriterStream.Create(stream) else
+ pb := TSuperUnicodeWriterStream.Create(stream);
+
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ pb.Reset;
+ pb.Free;
+ Result := 0;
+ Exit;
+ end;
+ Result := stream.Size;
+ pb.Free;
+end;
+
+function TSuperObject.CalcSize(indent, escape: boolean): integer;
+var
+ pb: TSuperWriterFake;
+begin
+ pb := TSuperWriterFake.Create;
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ pb.Free;
+ Result := 0;
+ Exit;
+ end;
+ Result := pb.FSize;
+ pb.Free;
+end;
+
+function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer;
+var
+ pb: TSuperWriterSock;
+begin
+ pb := TSuperWriterSock.Create(socket);
+ if(Write(pb, indent, escape, 0) < 0) then
+ begin
+ pb.Free;
+ Result := 0;
+ Exit;
+ end;
+ Result := pb.FSize;
+ pb.Free;
+end;
+
+constructor TSuperObject.Create(const s: SOString);
+begin
+ Create(stString);
+ FOString := s;
+end;
+
+procedure TSuperObject.Clear(all: boolean);
+begin
+ if FProcessing then exit;
+ FProcessing := true;
+ try
+ case FDataType of
+ stBoolean: FO.c_boolean := false;
+ stDouble: FO.c_double := 0.0;
+ stCurrency: FO.c_currency := 0.0;
+ stInt: FO.c_int := 0;
+ stObject: FO.c_object.Clear(all);
+ stArray: FO.c_array.Clear(all);
+ stString: FOString := '';
+{$IFDEF SUPER_METHOD}
+ stMethod: FO.c_method := nil;
+{$ENDIF}
+ end;
+ finally
+ FProcessing := false;
+ end;
+end;
+
+procedure TSuperObject.Pack(all: boolean = false);
+begin
+ if FProcessing then exit;
+ FProcessing := true;
+ try
+ case FDataType of
+ stObject: FO.c_object.Pack(all);
+ stArray: FO.c_array.Pack(all);
+ end;
+ finally
+ FProcessing := false;
+ end;
+end;
+
+function TSuperObject.GetN(const path: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, true, self);
+ if Result = nil then
+ Result := TSuperObject.Create(stNull);
+end;
+
+procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject);
+begin
+ if Value = nil then
+ ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else
+ ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value);
+end;
+
+function TSuperObject.Delete(const path: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, true, self, [foDelete]);
+end;
+
+function TSuperObject.Clone: ISuperObject;
+var
+ ite: TSuperObjectIter;
+ arr: TSuperArray;
+ j: integer;
+begin
+ case FDataType of
+ stBoolean: Result := TSuperObject.Create(FO.c_boolean);
+ stDouble: Result := TSuperObject.Create(FO.c_double);
+ stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency);
+ stInt: Result := TSuperObject.Create(FO.c_int);
+ stString: Result := TSuperObject.Create(FOString);
+{$IFDEF SUPER_METHOD}
+ stMethod: Result := TSuperObject.Create(FO.c_method);
+{$ENDIF}
+ stObject:
+ begin
+ Result := TSuperObject.Create(stObject);
+ if ObjectFindFirst(self, ite) then
+ with Result.AsObject do
+ repeat
+ PutO(ite.key, ite.val.Clone);
+ until not ObjectFindNext(ite);
+ ObjectFindClose(ite);
+ end;
+ stArray:
+ begin
+ Result := TSuperObject.Create(stArray);
+ arr := AsArray;
+ with Result.AsArray do
+ for j := 0 to arr.Length - 1 do
+ Add(arr.GetO(j).Clone);
+ end;
+ else
+ Result := nil;
+ end;
+end;
+
+procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean);
+var
+ prop1, prop2: ISuperObject;
+ ite: TSuperObjectIter;
+ arr: TSuperArray;
+ j: integer;
+begin
+ if ObjectIsType(obj, FDataType) then
+ case FDataType of
+ stBoolean: FO.c_boolean := obj.AsBoolean;
+ stDouble: FO.c_double := obj.AsDouble;
+ stCurrency: FO.c_currency := obj.AsCurrency;
+ stInt: FO.c_int := obj.AsInteger;
+ stString: FOString := obj.AsString;
+{$IFDEF SUPER_METHOD}
+ stMethod: FO.c_method := obj.AsMethod;
+{$ENDIF}
+ stObject:
+ begin
+ if ObjectFindFirst(obj, ite) then
+ with FO.c_object do
+ repeat
+ prop1 := FO.c_object.GetO(ite.key);
+ if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then
+ prop1.Merge(ite.val) else
+ if reference then
+ PutO(ite.key, ite.val) else
+ PutO(ite.key, ite.val.Clone);
+ until not ObjectFindNext(ite);
+ ObjectFindClose(ite);
+ end;
+ stArray:
+ begin
+ arr := obj.AsArray;
+ with FO.c_array do
+ for j := 0 to arr.Length - 1 do
+ begin
+ prop1 := GetO(j);
+ prop2 := arr.GetO(j);
+ if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then
+ prop1.Merge(prop2) else
+ if reference then
+ PutO(j, prop2) else
+ PutO(j, prop2.Clone);
+ end;
+ end;
+ end;
+end;
+
+procedure TSuperObject.Merge(const str: SOString);
+begin
+ Merge(TSuperObject.ParseString(PSOChar(str), False), true);
+end;
+
+class function TSuperObject.NewInstance: TObject;
+begin
+ Result := inherited NewInstance;
+ TSuperObject(Result).FRefCount := 1;
+end;
+
+function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType);
+end;
+
+function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString;
+var
+ p1, p2: PSOChar;
+begin
+ Result := '';
+ p2 := PSOChar(str);
+ p1 := p2;
+ while true do
+ if p2^ = BeginSep then
+ begin
+ if p2 > p1 then
+ Result := Result + Copy(p1, 0, p2-p1);
+ inc(p2);
+ p1 := p2;
+ while true do
+ if p2^ = EndSep then Break else
+ if p2^ = #0 then Exit else
+ inc(p2);
+ Result := Result + GetS(copy(p1, 0, p2-p1));
+ inc(p2);
+ p1 := p2;
+ end
+ else if p2^ = #0 then
+ begin
+ if p2 > p1 then
+ Result := Result + Copy(p1, 0, p2-p1);
+ Break;
+ end else
+ inc(p2);
+end;
+
+function TSuperObject.GetO(const path: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self);
+end;
+
+function TSuperObject.GetA(const path: SOString): TSuperArray;
+var
+ obj: ISuperObject;
+begin
+ obj := ParseString(PSOChar(path), False, True, Self);
+ if obj <> nil then
+ Result := obj.AsArray else
+ Result := nil;
+end;
+
+function TSuperObject.GetB(const path: SOString): Boolean;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsBoolean else
+ Result := false;
+end;
+
+function TSuperObject.GetD(const path: SOString): Double;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsDouble else
+ Result := 0.0;
+end;
+
+function TSuperObject.GetC(const path: SOString): Currency;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsCurrency else
+ Result := 0.0;
+end;
+
+function TSuperObject.GetI(const path: SOString): SuperInt;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsInteger else
+ Result := 0;
+end;
+
+function TSuperObject.GetDataPtr: Pointer;
+begin
+ Result := FDataPtr;
+end;
+
+function TSuperObject.GetDataType: TSuperType;
+begin
+ Result := FDataType
+end;
+
+function TSuperObject.GetS(const path: SOString): SOString;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(path);
+ if obj <> nil then
+ Result := obj.AsString else
+ Result := '';
+end;
+
+function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer;
+var
+ stream: TFileStream;
+begin
+ stream := TFileStream.Create(FileName, fmCreate);
+ try
+ Result := SaveTo(stream, indent, escape);
+ finally
+ stream.Free;
+ end;
+end;
+
+function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
+begin
+ Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender);
+end;
+
+function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean;
+type
+ TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool,
+ dtMap, dtSeq, dtScalar, dtAny);
+var
+ datatypes: ISuperObject;
+ names: ISuperObject;
+
+ function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject;
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ begin
+ o := p[prop];
+ if o <> nil then
+ result := o else
+ begin
+ o := p['inherit'];
+ if (o <> nil) and ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ Result := FindInheritedProperty(prop, e.Value) else
+ Result := nil;
+ end else
+ Result := nil;
+ end;
+ end;
+
+ function FindDataType(o: ISuperObject): TDataType;
+ var
+ e: TSuperAvlEntry;
+ obj: ISuperObject;
+ begin
+ obj := FindInheritedProperty('type', o);
+ if obj <> nil then
+ begin
+ e := datatypes.AsObject.Search(obj.AsString);
+ if e <> nil then
+ Result := TDataType(e.Value.AsInteger) else
+ Result := dtUnknown;
+ end else
+ Result := dtUnknown;
+ end;
+
+ procedure GetNames(o: ISuperObject);
+ var
+ obj: ISuperObject;
+ f: TSuperObjectIter;
+ begin
+ obj := o['name'];
+ if ObjectIsType(obj, stString) then
+ names[obj.AsString] := o;
+
+ case FindDataType(o) of
+ dtMap:
+ begin
+ obj := o['mapping'];
+ if ObjectIsType(obj, stObject) then
+ begin
+ if ObjectFindFirst(obj, f) then
+ repeat
+ if ObjectIsType(f.val, stObject) then
+ GetNames(f.val);
+ until not ObjectFindNext(f);
+ ObjectFindClose(f);
+ end;
+ end;
+ dtSeq:
+ begin
+ obj := o['sequence'];
+ if ObjectIsType(obj, stObject) then
+ GetNames(obj);
+ end;
+ end;
+ end;
+
+ function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject;
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ begin
+ o := p['mapping'];
+ if ObjectIsType(o, stObject) then
+ begin
+ o := o.AsObject.GetO(prop);
+ if o <> nil then
+ begin
+ Result := o;
+ Exit;
+ end;
+ end;
+
+ o := p['inherit'];
+ if ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ Result := FindInheritedField(prop, e.Value) else
+ Result := nil;
+ end else
+ Result := nil;
+ end;
+
+ function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean;
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ j: TSuperAvlIterator;
+ begin
+ Result := true;
+ o := p['mapping'];
+ if ObjectIsType(o, stObject) then
+ begin
+ j := TSuperAvlIterator.Create(o.AsObject);
+ try
+ j.First;
+ e := j.GetIter;
+ while e <> nil do
+ begin
+ if obj.AsObject.Search(e.Name) = nil then
+ begin
+ Result := False;
+ if assigned(callback) then
+ callback(sender, veFieldNotFound, name + '.' + e.Name);
+ end;
+ j.Next;
+ e := j.GetIter;
+ end;
+
+ finally
+ j.Free;
+ end;
+ end;
+
+ o := p['inherit'];
+ if ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ Result := InheritedFieldExist(obj, e.Value, name) and Result;
+ end;
+ end;
+
+ function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean;
+ var
+ o: ISuperObject;
+ begin
+ o := FindInheritedProperty(f, p);
+ case ObjectGetType(o) of
+ stBoolean: Result := o.AsBoolean;
+ stNull: Result := Default;
+ else
+ Result := default;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, f);
+ end;
+ end;
+
+ procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject);
+ var
+ o: ISuperObject;
+ e: TSuperAvlEntry;
+ i: TSuperAvlIterator;
+ begin
+ Result := true;
+ o := p['mapping'];
+ if ObjectIsType(o, stObject) then
+ begin
+ i := TSuperAvlIterator.Create(o.AsObject);
+ try
+ i.First;
+ e := i.GetIter;
+ while e <> nil do
+ begin
+ if list.AsObject.Search(e.Name) = nil then
+ list[e.Name] := e.Value;
+ i.Next;
+ e := i.GetIter;
+ end;
+
+ finally
+ i.Free;
+ end;
+ end;
+
+ o := p['inherit'];
+ if ObjectIsType(o, stString) then
+ begin
+ e := names.AsObject.Search(o.AsString);
+ if (e <> nil) then
+ GetInheritedFieldList(list, e.Value);
+ end;
+ end;
+
+ function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean;
+ var
+ enum: ISuperObject;
+ i: integer;
+ begin
+ Result := false;
+ enum := FindInheritedProperty('enum', p);
+ case ObjectGetType(enum) of
+ stArray:
+ for i := 0 to enum.AsArray.Length - 1 do
+ if (o.AsString = enum.AsArray[i].AsString) then
+ begin
+ Result := true;
+ exit;
+ end;
+ stNull: Result := true;
+ else
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ Exit;
+ end;
+
+ if (not Result) and assigned(callback) then
+ callback(sender, veValueNotInEnum, name);
+ end;
+
+ function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean;
+ var
+ length, o: ISuperObject;
+ begin
+ result := true;
+ length := FindInheritedProperty('length', p);
+ case ObjectGetType(length) of
+ stObject:
+ begin
+ o := length.AsObject.GetO('min');
+ if (o <> nil) and (o.AsInteger > len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ o := length.AsObject.GetO('max');
+ if (o <> nil) and (o.AsInteger < len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ o := length.AsObject.GetO('minex');
+ if (o <> nil) and (o.AsInteger >= len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ o := length.AsObject.GetO('maxex');
+ if (o <> nil) and (o.AsInteger <= len) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidLength, objpath);
+ end;
+ end;
+ stNull: ;
+ else
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ end;
+ end;
+
+ function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean;
+ var
+ length, o: ISuperObject;
+ begin
+ result := true;
+ length := FindInheritedProperty('range', p);
+ case ObjectGetType(length) of
+ stObject:
+ begin
+ o := length.AsObject.GetO('min');
+ if (o <> nil) and (o.Compare(obj) = cpGreat) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ o := length.AsObject.GetO('max');
+ if (o <> nil) and (o.Compare(obj) = cpLess) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ o := length.AsObject.GetO('minex');
+ if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ o := length.AsObject.GetO('maxex');
+ if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then
+ begin
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veInvalidRange, objpath);
+ end;
+ end;
+ stNull: ;
+ else
+ Result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ end;
+ end;
+
+
+ function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean;
+ var
+ ite: TSuperAvlIterator;
+ ent: TSuperAvlEntry;
+ p2, o2, sequence: ISuperObject;
+ s: SOString;
+ i: integer;
+ uniquelist, fieldlist: ISuperObject;
+ begin
+ Result := true;
+ if (o = nil) then
+ begin
+ if getInheritedBool('required', p) then
+ begin
+ if assigned(callback) then
+ callback(sender, veFieldIsRequired, objpath);
+ result := false;
+ end;
+ end else
+ case FindDataType(p) of
+ dtStr:
+ case ObjectGetType(o) of
+ stString:
+ begin
+ Result := Result and CheckLength(Length(o.AsString), p, objpath);
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtBool:
+ case ObjectGetType(o) of
+ stBoolean:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtInt:
+ case ObjectGetType(o) of
+ stInt:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtFloat:
+ case ObjectGetType(o) of
+ stDouble, stCurrency:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtMap:
+ case ObjectGetType(o) of
+ stObject:
+ begin
+ // all objects have and match a rule ?
+ ite := TSuperAvlIterator.Create(o.AsObject);
+ try
+ ite.First;
+ ent := ite.GetIter;
+ while ent <> nil do
+ begin
+ p2 := FindInheritedField(ent.Name, p);
+ if ObjectIsType(p2, stObject) then
+ result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else
+ begin
+ if assigned(callback) then
+ callback(sender, veUnexpectedField, objpath + '.' + ent.Name);
+ result := false; // field have no rule
+ end;
+ ite.Next;
+ ent := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+
+ // all expected field exists ?
+ Result := InheritedFieldExist(o, p, objpath) and Result;
+ end;
+ stNull: {nop};
+ else
+ result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ end;
+ dtSeq:
+ case ObjectGetType(o) of
+ stArray:
+ begin
+ sequence := FindInheritedProperty('sequence', p);
+ if sequence <> nil then
+ case ObjectGetType(sequence) of
+ stObject:
+ begin
+ for i := 0 to o.AsArray.Length - 1 do
+ result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result;
+ if getInheritedBool('unique', sequence) then
+ begin
+ // type is unique ?
+ uniquelist := TSuperObject.Create(stObject);
+ try
+ for i := 0 to o.AsArray.Length - 1 do
+ begin
+ s := o.AsArray.GetO(i).AsString;
+ if (s <> '') then
+ begin
+ if uniquelist.AsObject.Search(s) = nil then
+ uniquelist[s] := nil else
+ begin
+ Result := False;
+ if Assigned(callback) then
+ callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']');
+ end;
+ end;
+ end;
+ finally
+ uniquelist := nil;
+ end;
+ end;
+
+ // field is unique ?
+ if (FindDataType(sequence) = dtMap) then
+ begin
+ fieldlist := TSuperObject.Create(stObject);
+ try
+ GetInheritedFieldList(fieldlist, sequence);
+ ite := TSuperAvlIterator.Create(fieldlist.AsObject);
+ try
+ ite.First;
+ ent := ite.GetIter;
+ while ent <> nil do
+ begin
+ if getInheritedBool('unique', ent.Value) then
+ begin
+ uniquelist := TSuperObject.Create(stObject);
+ try
+ for i := 0 to o.AsArray.Length - 1 do
+ begin
+ o2 := o.AsArray.GetO(i);
+ if o2 <> nil then
+ begin
+ s := o2.AsObject.GetO(ent.Name).AsString;
+ if (s <> '') then
+ if uniquelist.AsObject.Search(s) = nil then
+ uniquelist[s] := nil else
+ begin
+ Result := False;
+ if Assigned(callback) then
+ callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name);
+ end;
+ end;
+ end;
+ finally
+ uniquelist := nil;
+ end;
+ end;
+ ite.Next;
+ ent := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+ finally
+ fieldlist := nil;
+ end;
+ end;
+
+
+ end;
+ stNull: {nop};
+ else
+ result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ end;
+ Result := Result and CheckLength(o.AsArray.Length, p, objpath);
+
+ end;
+ else
+ result := false;
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ end;
+ dtNumber:
+ case ObjectGetType(o) of
+ stInt,
+ stDouble, stCurrency:
+ begin
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtText:
+ case ObjectGetType(o) of
+ stInt,
+ stDouble,
+ stCurrency,
+ stString:
+ begin
+ result := result and CheckLength(Length(o.AsString), p, objpath);
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtScalar:
+ case ObjectGetType(o) of
+ stBoolean,
+ stDouble,
+ stCurrency,
+ stInt,
+ stString:
+ begin
+ result := result and CheckLength(Length(o.AsString), p, objpath);
+ Result := Result and CheckRange(o, p, objpath);
+ end;
+ else
+ if assigned(callback) then
+ callback(sender, veInvalidDataType, objpath);
+ result := false;
+ end;
+ dtAny:;
+ else
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, objpath);
+ result := false;
+ end;
+ Result := Result and CheckEnum(o, p, objpath)
+
+ end;
+var
+ j: integer;
+
+begin
+ Result := False;
+ datatypes := TSuperObject.Create(stObject);
+ names := TSuperObject.Create;
+ try
+ datatypes.I['str'] := ord(dtStr);
+ datatypes.I['int'] := ord(dtInt);
+ datatypes.I['float'] := ord(dtFloat);
+ datatypes.I['number'] := ord(dtNumber);
+ datatypes.I['text'] := ord(dtText);
+ datatypes.I['bool'] := ord(dtBool);
+ datatypes.I['map'] := ord(dtMap);
+ datatypes.I['seq'] := ord(dtSeq);
+ datatypes.I['scalar'] := ord(dtScalar);
+ datatypes.I['any'] := ord(dtAny);
+
+ if ObjectIsType(defs, stArray) then
+ for j := 0 to defs.AsArray.Length - 1 do
+ if ObjectIsType(defs.AsArray[j], stObject) then
+ GetNames(defs.AsArray[j]) else
+ begin
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ Exit;
+ end;
+
+
+ if ObjectIsType(rules, stObject) then
+ GetNames(rules) else
+ begin
+ if assigned(callback) then
+ callback(sender, veRuleMalformated, '');
+ Exit;
+ end;
+
+ Result := process(self, rules);
+
+ finally
+ datatypes := nil;
+ names := nil;
+ end;
+end;
+
+function TSuperObject._AddRef: Integer; stdcall;
+begin
+ Result := InterlockedIncrement(FRefCount);
+end;
+
+function TSuperObject._Release: Integer; stdcall;
+begin
+ Result := InterlockedDecrement(FRefCount);
+ if Result = 0 then
+ Destroy;
+end;
+
+function TSuperObject.Compare(const str: SOString): TSuperCompareResult;
+begin
+ Result := Compare(TSuperObject.ParseString(PSOChar(str), False));
+end;
+
+function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult;
+ function GetIntCompResult(const i: int64): TSuperCompareResult;
+ begin
+ if i < 0 then result := cpLess else
+ if i = 0 then result := cpEqu else
+ Result := cpGreat;
+ end;
+
+ function GetDblCompResult(const d: double): TSuperCompareResult;
+ begin
+ if d < 0 then result := cpLess else
+ if d = 0 then result := cpEqu else
+ Result := cpGreat;
+ end;
+
+begin
+ case DataType of
+ stBoolean:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency);
+ stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stDouble:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency);
+ stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stCurrency:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency);
+ stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stInt:
+ case ObjectGetType(obj) of
+ stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean));
+ stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble);
+ stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency);
+ stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger);
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ stString:
+ case ObjectGetType(obj) of
+ stBoolean,
+ stDouble,
+ stCurrency,
+ stInt,
+ stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString)));
+ else
+ Result := cpError;
+ end;
+ else
+ Result := cpError;
+ end;
+end;
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.AsMethod: TSuperMethod;
+begin
+ if FDataType = stMethod then
+ Result := FO.c_method else
+ Result := nil;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+constructor TSuperObject.Create(m: TSuperMethod);
+begin
+ Create(stMethod);
+ FO.c_method := m;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.GetM(const path: SOString): TSuperMethod;
+var
+ v: ISuperObject;
+begin
+ v := ParseString(PSOChar(path), False, True, Self);
+ if (v <> nil) and (ObjectGetType(v) = stMethod) then
+ Result := v.AsMethod else
+ Result := nil;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod);
+begin
+ ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value));
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param);
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperObject.call(const path, param: SOString): ISuperObject;
+begin
+ Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False));
+end;
+{$ENDIF}
+
+function TSuperObject.GetProcessing: boolean;
+begin
+ Result := FProcessing;
+end;
+
+procedure TSuperObject.SetDataPtr(const Value: Pointer);
+begin
+ FDataPtr := Value;
+end;
+
+procedure TSuperObject.SetProcessing(value: boolean);
+begin
+ FProcessing := value;
+end;
+
+{ TSuperArray }
+
+function TSuperArray.Add(const Data: ISuperObject): Integer;
+begin
+ Result := FLength;
+ PutO(Result, data);
+end;
+
+function TSuperArray.Delete(index: Integer): ISuperObject;
+begin
+ if (Index >= 0) and (Index < FLength) then
+ begin
+ Result := FArray^[index];
+ FArray^[index] := nil;
+ Dec(FLength);
+ if Index < FLength then
+ begin
+ Move(FArray^[index + 1], FArray^[index],
+ (FLength - index) * SizeOf(Pointer));
+ Pointer(FArray^[FLength]) := nil;
+ end;
+ end;
+end;
+
+procedure TSuperArray.Insert(index: Integer; const value: ISuperObject);
+begin
+ if (Index >= 0) then
+ if (index < FLength) then
+ begin
+ if FLength = FSize then
+ Expand(index);
+ if Index < FLength then
+ Move(FArray^[index], FArray^[index + 1],
+ (FLength - index) * SizeOf(Pointer));
+ Pointer(FArray^[index]) := nil;
+ FArray^[index] := value;
+ Inc(FLength);
+ end else
+ PutO(index, value);
+end;
+
+procedure TSuperArray.Clear(all: boolean);
+var
+ j: Integer;
+begin
+ for j := 0 to FLength - 1 do
+ if FArray^[j] <> nil then
+ begin
+ if all then
+ FArray^[j].Clear(all);
+ FArray^[j] := nil;
+ end;
+ FLength := 0;
+end;
+
+procedure TSuperArray.Pack(all: boolean);
+var
+ PackedCount, StartIndex, EndIndex, j: Integer;
+begin
+ if FLength > 0 then
+ begin
+ PackedCount := 0;
+ StartIndex := 0;
+ repeat
+ while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do
+ Inc(StartIndex);
+ if StartIndex < FLength then
+ begin
+ EndIndex := StartIndex;
+ while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do
+ Inc(EndIndex);
+
+ Dec(EndIndex);
+
+ if StartIndex > PackedCount then
+ Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer));
+
+ Inc(PackedCount, EndIndex - StartIndex + 1);
+ StartIndex := EndIndex + 1;
+ end;
+ until StartIndex >= FLength;
+ FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0);
+ FLength := PackedCount;
+ if all then
+ for j := 0 to FLength - 1 do
+ FArray^[j].Pack(all);
+ end;
+end;
+
+constructor TSuperArray.Create;
+begin
+ inherited Create;
+ FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE;
+ FLength := 0;
+ GetMem(FArray, sizeof(Pointer) * FSize);
+ FillChar(FArray^, sizeof(Pointer) * FSize, 0);
+end;
+
+destructor TSuperArray.Destroy;
+begin
+ Clear;
+ FreeMem(FArray);
+ inherited;
+end;
+
+procedure TSuperArray.Expand(max: Integer);
+var
+ new_size: Integer;
+begin
+ if (max < FSize) then
+ Exit;
+ if max < (FSize shl 1) then
+ new_size := (FSize shl 1) else
+ new_size := max + 1;
+ ReallocMem(FArray, new_size * sizeof(Pointer));
+ FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0);
+ FSize := new_size;
+end;
+
+function TSuperArray.GetO(const index: Integer): ISuperObject;
+begin
+ if(index >= FLength) then
+ Result := nil else
+ Result := FArray^[index];
+end;
+
+function TSuperArray.GetB(const index: integer): Boolean;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsBoolean else
+ Result := false;
+end;
+
+function TSuperArray.GetD(const index: integer): Double;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsDouble else
+ Result := 0.0;
+end;
+
+function TSuperArray.GetI(const index: integer): SuperInt;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsInteger else
+ Result := 0;
+end;
+
+function TSuperArray.GetS(const index: integer): SOString;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsString else
+ Result := '';
+end;
+
+procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject);
+begin
+ Expand(index);
+ FArray^[index] := value;
+ if(FLength <= index) then FLength := index + 1;
+end;
+
+function TSuperArray.GetN(const index: integer): ISuperObject;
+begin
+ Result := GetO(index);
+ if Result = nil then
+ Result := TSuperObject.Create(stNull);
+end;
+
+procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject);
+begin
+ if Value <> nil then
+ PutO(index, Value) else
+ PutO(index, TSuperObject.Create(stNull));
+end;
+
+procedure TSuperArray.PutB(const index: integer; Value: Boolean);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+procedure TSuperArray.PutD(const index: integer; Value: Double);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+function TSuperArray.GetC(const index: integer): Currency;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(index);
+ if obj <> nil then
+ Result := obj.AsCurrency else
+ Result := 0.0;
+end;
+
+procedure TSuperArray.PutC(const index: integer; Value: Currency);
+begin
+ PutO(index, TSuperObject.CreateCurrency(Value));
+end;
+
+procedure TSuperArray.PutI(const index: integer; Value: SuperInt);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+procedure TSuperArray.PutS(const index: integer; const Value: SOString);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+
+{$IFDEF SUPER_METHOD}
+function TSuperArray.GetM(const index: integer): TSuperMethod;
+var
+ v: ISuperObject;
+begin
+ v := GetO(index);
+ if (ObjectGetType(v) = stMethod) then
+ Result := v.AsMethod else
+ Result := nil;
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod);
+begin
+ PutO(index, TSuperObject.Create(Value));
+end;
+{$ENDIF}
+
+{ TSuperWriterString }
+
+function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer;
+ function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end;
+begin
+ Result := size;
+ if Size > 0 then
+ begin
+ if (FSize - FBPos <= size) then
+ begin
+ FSize := max(FSize * 2, FBPos + size + 8);
+ ReallocMem(FBuf, FSize * SizeOf(SOChar));
+ end;
+ // fast move
+ case size of
+ 1: FBuf[FBPos] := buf^;
+ 2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^;
+ 4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^;
+ else
+ move(buf^, FBuf[FBPos], size * SizeOf(SOChar));
+ end;
+ inc(FBPos, size);
+ FBuf[FBPos] := #0;
+ end;
+end;
+
+function TSuperWriterString.Append(buf: PSOChar): Integer;
+begin
+ Result := Append(buf, strlen(buf));
+end;
+
+constructor TSuperWriterString.Create;
+begin
+ inherited;
+ FSize := 32;
+ FBPos := 0;
+ GetMem(FBuf, FSize * SizeOf(SOChar));
+end;
+
+destructor TSuperWriterString.Destroy;
+begin
+ inherited;
+ if FBuf <> nil then
+ FreeMem(FBuf)
+end;
+
+function TSuperWriterString.GetString: SOString;
+begin
+ SetString(Result, FBuf, FBPos);
+end;
+
+procedure TSuperWriterString.Reset;
+begin
+ FBuf[0] := #0;
+ FBPos := 0;
+end;
+
+procedure TSuperWriterString.TrimRight;
+begin
+ while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do
+ begin
+ dec(FBPos);
+ FBuf[FBPos] := #0;
+ end;
+end;
+
+{ TSuperWriterStream }
+
+function TSuperWriterStream.Append(buf: PSOChar): Integer;
+begin
+ Result := Append(buf, StrLen(buf));
+end;
+
+constructor TSuperWriterStream.Create(AStream: TStream);
+begin
+ inherited Create;
+ FStream := AStream;
+end;
+
+procedure TSuperWriterStream.Reset;
+begin
+ FStream.Size := 0;
+end;
+
+{ TSuperWriterStream }
+
+function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
+var
+ Buffer: array[0..1023] of AnsiChar;
+ pBuffer: PAnsiChar;
+ i: Integer;
+begin
+ if Size = 1 then
+ Result := FStream.Write(buf^, Size) else
+ begin
+ if Size > SizeOf(Buffer) then
+ GetMem(pBuffer, Size) else
+ pBuffer := @Buffer;
+ try
+ for i := 0 to Size - 1 do
+ pBuffer[i] := AnsiChar(buf[i]);
+ Result := FStream.Write(pBuffer^, Size);
+ finally
+ if pBuffer <> @Buffer then
+ FreeMem(pBuffer);
+ end;
+ end;
+end;
+
+{ TSuperUnicodeWriterStream }
+
+function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer;
+begin
+ Result := FStream.Write(buf^, Size * 2);
+end;
+
+{ TSuperWriterFake }
+
+function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer;
+begin
+ inc(FSize, Size);
+ Result := FSize;
+end;
+
+function TSuperWriterFake.Append(buf: PSOChar): Integer;
+begin
+ inc(FSize, Strlen(buf));
+ Result := FSize;
+end;
+
+constructor TSuperWriterFake.Create;
+begin
+ inherited Create;
+ FSize := 0;
+end;
+
+procedure TSuperWriterFake.Reset;
+begin
+ FSize := 0;
+end;
+
+{ TSuperWriterSock }
+
+function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer;
+var
+ Buffer: array[0..1023] of AnsiChar;
+ pBuffer: PAnsiChar;
+ i: Integer;
+begin
+ if Size = 1 then
+{$IFDEF FPC}
+ Result := fpsend(FSocket, buf, size, 0) else
+{$ELSE}
+ Result := send(FSocket, buf^, size, 0) else
+{$ENDIF}
+ begin
+ if Size > SizeOf(Buffer) then
+ GetMem(pBuffer, Size) else
+ pBuffer := @Buffer;
+ try
+ for i := 0 to Size - 1 do
+ pBuffer[i] := AnsiChar(buf[i]);
+{$IFDEF FPC}
+ Result := fpsend(FSocket, pBuffer, size, 0);
+{$ELSE}
+ Result := send(FSocket, pBuffer^, size, 0);
+{$ENDIF}
+ finally
+ if pBuffer <> @Buffer then
+ FreeMem(pBuffer);
+ end;
+ end;
+ inc(FSize, Result);
+end;
+
+function TSuperWriterSock.Append(buf: PSOChar): Integer;
+begin
+ Result := Append(buf, StrLen(buf));
+end;
+
+constructor TSuperWriterSock.Create(ASocket: Integer);
+begin
+ inherited Create;
+ FSocket := ASocket;
+ FSize := 0;
+end;
+
+procedure TSuperWriterSock.Reset;
+begin
+ FSize := 0;
+end;
+
+{ TSuperTokenizer }
+
+constructor TSuperTokenizer.Create;
+begin
+ pb := TSuperWriterString.Create;
+ line := 1;
+ col := 0;
+ Reset;
+end;
+
+destructor TSuperTokenizer.Destroy;
+begin
+ Reset;
+ pb.Free;
+ inherited;
+end;
+
+procedure TSuperTokenizer.Reset;
+var
+ i: integer;
+begin
+ for i := depth downto 0 do
+ ResetLevel(i);
+ depth := 0;
+ err := teSuccess;
+end;
+
+procedure TSuperTokenizer.ResetLevel(adepth: integer);
+begin
+ stack[adepth].state := tsEatws;
+ stack[adepth].saved_state := tsStart;
+ stack[adepth].current := nil;
+ stack[adepth].field_name := '';
+ stack[adepth].obj := nil;
+ stack[adepth].parent := nil;
+ stack[adepth].gparent := nil;
+end;
+
+{ TSuperAvlTree }
+
+constructor TSuperAvlTree.Create;
+begin
+ FRoot := nil;
+ FCount := 0;
+end;
+
+destructor TSuperAvlTree.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+
+function TSuperAvlTree.IsEmpty: boolean;
+begin
+ result := FRoot = nil;
+end;
+
+function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry;
+var
+ deep, old: TSuperAvlEntry;
+ bf: integer;
+begin
+ if (bal.FBf > 0) then
+ begin
+ deep := bal.FGt;
+ if (deep.FBf < 0) then
+ begin
+ old := bal;
+ bal := deep.FLt;
+ old.FGt := bal.FLt;
+ deep.FLt := bal.FGt;
+ bal.FLt := old;
+ bal.FGt := deep;
+ bf := bal.FBf;
+ if (bf <> 0) then
+ begin
+ if (bf > 0) then
+ begin
+ old.FBf := -1;
+ deep.FBf := 0;
+ end else
+ begin
+ deep.FBf := 1;
+ old.FBf := 0;
+ end;
+ bal.FBf := 0;
+ end else
+ begin
+ old.FBf := 0;
+ deep.FBf := 0;
+ end;
+ end else
+ begin
+ bal.FGt := deep.FLt;
+ deep.FLt := bal;
+ if (deep.FBf = 0) then
+ begin
+ deep.FBf := -1;
+ bal.FBf := 1;
+ end else
+ begin
+ deep.FBf := 0;
+ bal.FBf := 0;
+ end;
+ bal := deep;
+ end;
+ end else
+ begin
+ (* "Less than" subtree is deeper. *)
+
+ deep := bal.FLt;
+ if (deep.FBf > 0) then
+ begin
+ old := bal;
+ bal := deep.FGt;
+ old.FLt := bal.FGt;
+ deep.FGt := bal.FLt;
+ bal.FGt := old;
+ bal.FLt := deep;
+
+ bf := bal.FBf;
+ if (bf <> 0) then
+ begin
+ if (bf < 0) then
+ begin
+ old.FBf := 1;
+ deep.FBf := 0;
+ end else
+ begin
+ deep.FBf := -1;
+ old.FBf := 0;
+ end;
+ bal.FBf := 0;
+ end else
+ begin
+ old.FBf := 0;
+ deep.FBf := 0;
+ end;
+ end else
+ begin
+ bal.FLt := deep.FGt;
+ deep.FGt := bal;
+ if (deep.FBf = 0) then
+ begin
+ deep.FBf := 1;
+ bal.FBf := -1;
+ end else
+ begin
+ deep.FBf := 0;
+ bal.FBf := 0;
+ end;
+ bal := deep;
+ end;
+ end;
+ Result := bal;
+end;
+
+function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry;
+var
+ unbal, parentunbal, hh, parent: TSuperAvlEntry;
+ depth, unbaldepth: longint;
+ cmp: integer;
+ unbalbf: integer;
+ branch: TSuperAvlBitArray;
+ p: Pointer;
+begin
+ inc(FCount);
+ h.FLt := nil;
+ h.FGt := nil;
+ h.FBf := 0;
+ branch := [];
+
+ if (FRoot = nil) then
+ FRoot := h
+ else
+ begin
+ unbal := nil;
+ parentunbal := nil;
+ depth := 0;
+ unbaldepth := 0;
+ hh := FRoot;
+ parent := nil;
+ repeat
+ if (hh.FBf <> 0) then
+ begin
+ unbal := hh;
+ parentunbal := parent;
+ unbaldepth := depth;
+ end;
+ if hh.FHash <> h.FHash then
+ begin
+ if hh.FHash < h.FHash then cmp := -1 else
+ if hh.FHash > h.FHash then cmp := 1 else
+ cmp := 0;
+ end else
+ cmp := CompareNodeNode(h, hh);
+ if (cmp = 0) then
+ begin
+ Result := hh;
+ //exchange data
+ p := hh.Ptr;
+ hh.FPtr := h.Ptr;
+ h.FPtr := p;
+ doDeleteEntry(h, false);
+ dec(FCount);
+ exit;
+ end;
+ parent := hh;
+ if (cmp > 0) then
+ begin
+ hh := hh.FGt;
+ include(branch, depth);
+ end else
+ begin
+ hh := hh.FLt;
+ exclude(branch, depth);
+ end;
+ inc(depth);
+ until (hh = nil);
+
+ if (cmp < 0) then
+ parent.FLt := h else
+ parent.FGt := h;
+
+ depth := unbaldepth;
+
+ if (unbal = nil) then
+ hh := FRoot
+ else
+ begin
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ inc(depth);
+ unbalbf := unbal.FBf;
+ if (cmp < 0) then
+ dec(unbalbf) else
+ inc(unbalbf);
+ if cmp < 0 then
+ hh := unbal.FLt else
+ hh := unbal.FGt;
+ if ((unbalbf <> -2) and (unbalbf <> 2)) then
+ begin
+ unbal.FBf := unbalbf;
+ unbal := nil;
+ end;
+ end;
+
+ if (hh <> nil) then
+ while (h <> hh) do
+ begin
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ inc(depth);
+ if (cmp < 0) then
+ begin
+ hh.FBf := -1;
+ hh := hh.FLt;
+ end else (* cmp > 0 *)
+ begin
+ hh.FBf := 1;
+ hh := hh.FGt;
+ end;
+ end;
+
+ if (unbal <> nil) then
+ begin
+ unbal := balance(unbal);
+ if (parentunbal = nil) then
+ FRoot := unbal
+ else
+ begin
+ depth := unbaldepth - 1;
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ if (cmp < 0) then
+ parentunbal.FLt := unbal else
+ parentunbal.FGt := unbal;
+ end;
+ end;
+ end;
+ result := h;
+end;
+
+function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry;
+var
+ cmp, target_cmp: integer;
+ match_h, h: TSuperAvlEntry;
+ ha: Cardinal;
+begin
+ ha := TSuperAvlEntry.Hash(k);
+
+ match_h := nil;
+ h := FRoot;
+
+ if (stLess in st) then
+ target_cmp := 1 else
+ if (stGreater in st) then
+ target_cmp := -1 else
+ target_cmp := 0;
+
+ while (h <> nil) do
+ begin
+ if h.FHash < ha then cmp := -1 else
+ if h.FHash > ha then cmp := 1 else
+ cmp := 0;
+
+ if cmp = 0 then
+ cmp := CompareKeyNode(PSOChar(k), h);
+ if (cmp = 0) then
+ begin
+ if (stEqual in st) then
+ begin
+ match_h := h;
+ break;
+ end;
+ cmp := -target_cmp;
+ end
+ else
+ if (target_cmp <> 0) then
+ if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
+ match_h := h;
+ if cmp < 0 then
+ h := h.FLt else
+ h := h.FGt;
+ end;
+ result := match_h;
+end;
+
+function TSuperAvlTree.Delete(const k: SOString): ISuperObject;
+var
+ depth, rm_depth: longint;
+ branch: TSuperAvlBitArray;
+ h, parent, child, path, rm, parent_rm: TSuperAvlEntry;
+ cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer;
+ ha: Cardinal;
+begin
+ ha := TSuperAvlEntry.Hash(k);
+ cmp_shortened_sub_with_path := 0;
+ branch := [];
+
+ depth := 0;
+ h := FRoot;
+ parent := nil;
+ while true do
+ begin
+ if (h = nil) then
+ exit;
+ if h.FHash < ha then cmp := -1 else
+ if h.FHash > ha then cmp := 1 else
+ cmp := 0;
+
+ if cmp = 0 then
+ cmp := CompareKeyNode(k, h);
+ if (cmp = 0) then
+ break;
+ parent := h;
+ if (cmp > 0) then
+ begin
+ h := h.FGt;
+ include(branch, depth)
+ end else
+ begin
+ h := h.FLt;
+ exclude(branch, depth)
+ end;
+ inc(depth);
+ cmp_shortened_sub_with_path := cmp;
+ end;
+ rm := h;
+ parent_rm := parent;
+ rm_depth := depth;
+
+ if (h.FBf < 0) then
+ begin
+ child := h.FLt;
+ exclude(branch, depth);
+ cmp := -1;
+ end else
+ begin
+ child := h.FGt;
+ include(branch, depth);
+ cmp := 1;
+ end;
+ inc(depth);
+
+ if (child <> nil) then
+ begin
+ cmp := -cmp;
+ repeat
+ parent := h;
+ h := child;
+ if (cmp < 0) then
+ begin
+ child := h.FLt;
+ exclude(branch, depth);
+ end else
+ begin
+ child := h.FGt;
+ include(branch, depth);
+ end;
+ inc(depth);
+ until (child = nil);
+
+ if (parent = rm) then
+ cmp_shortened_sub_with_path := -cmp else
+ cmp_shortened_sub_with_path := cmp;
+
+ if cmp > 0 then
+ child := h.FLt else
+ child := h.FGt;
+ end;
+
+ if (parent = nil) then
+ FRoot := child else
+ if (cmp_shortened_sub_with_path < 0) then
+ parent.FLt := child else
+ parent.FGt := child;
+
+ if parent = rm then
+ path := h else
+ path := parent;
+
+ if (h <> rm) then
+ begin
+ h.FLt := rm.FLt;
+ h.FGt := rm.FGt;
+ h.FBf := rm.FBf;
+ if (parent_rm = nil) then
+ FRoot := h
+ else
+ begin
+ depth := rm_depth - 1;
+ if (depth in branch) then
+ parent_rm.FGt := h else
+ parent_rm.FLt := h;
+ end;
+ end;
+
+ if (path <> nil) then
+ begin
+ h := FRoot;
+ parent := nil;
+ depth := 0;
+ while (h <> path) do
+ begin
+ if (depth in branch) then
+ begin
+ child := h.FGt;
+ h.FGt := parent;
+ end else
+ begin
+ child := h.FLt;
+ h.FLt := parent;
+ end;
+ inc(depth);
+ parent := h;
+ h := child;
+ end;
+
+ reduced_depth := 1;
+ cmp := cmp_shortened_sub_with_path;
+ while true do
+ begin
+ if (reduced_depth <> 0) then
+ begin
+ bf := h.FBf;
+ if (cmp < 0) then
+ inc(bf) else
+ dec(bf);
+ if ((bf = -2) or (bf = 2)) then
+ begin
+ h := balance(h);
+ bf := h.FBf;
+ end else
+ h.FBf := bf;
+ reduced_depth := integer(bf = 0);
+ end;
+ if (parent = nil) then
+ break;
+ child := h;
+ h := parent;
+ dec(depth);
+ if depth in branch then
+ cmp := 1 else
+ cmp := -1;
+ if (cmp < 0) then
+ begin
+ parent := h.FLt;
+ h.FLt := child;
+ end else
+ begin
+ parent := h.FGt;
+ h.FGt := child;
+ end;
+ end;
+ FRoot := h;
+ end;
+ if rm <> nil then
+ begin
+ Result := rm.GetValue;
+ doDeleteEntry(rm, false);
+ dec(FCount);
+ end;
+end;
+
+procedure TSuperAvlTree.Pack(all: boolean);
+var
+ node1, node2: TSuperAvlEntry;
+ list: TList;
+ i: Integer;
+begin
+ node1 := FRoot;
+ list := TList.Create;
+ while node1 <> nil do
+ begin
+ if (node1.FLt = nil) then
+ begin
+ node2 := node1.FGt;
+ if (node1.FPtr = nil) then
+ list.Add(node1) else
+ if all then
+ node1.Value.Pack(all);
+ end
+ else
+ begin
+ node2 := node1.FLt;
+ node1.FLt := node2.FGt;
+ node2.FGt := node1;
+ end;
+ node1 := node2;
+ end;
+ for i := 0 to list.Count - 1 do
+ Delete(TSuperAvlEntry(list[i]).FName);
+ list.Free;
+end;
+
+procedure TSuperAvlTree.Clear(all: boolean);
+var
+ node1, node2: TSuperAvlEntry;
+begin
+ node1 := FRoot;
+ while node1 <> nil do
+ begin
+ if (node1.FLt = nil) then
+ begin
+ node2 := node1.FGt;
+ doDeleteEntry(node1, all);
+ end
+ else
+ begin
+ node2 := node1.FLt;
+ node1.FLt := node2.FGt;
+ node2.FGt := node1;
+ end;
+ node1 := node2;
+ end;
+ FRoot := nil;
+ FCount := 0;
+end;
+
+function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer;
+begin
+ Result := StrComp(PSOChar(k), PSOChar(h.FName));
+end;
+
+function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer;
+begin
+ Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName));
+end;
+
+{ TSuperAvlIterator }
+
+(* Initialize depth to invalid value, to indicate iterator is
+** invalid. (Depth is zero-base.) It's not necessary to initialize
+** iterators prior to passing them to the "start" function.
+*)
+
+constructor TSuperAvlIterator.Create(tree: TSuperAvlTree);
+begin
+ FDepth := not 0;
+ FTree := tree;
+end;
+
+procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes);
+var
+ h: TSuperAvlEntry;
+ d: longint;
+ cmp, target_cmp: integer;
+ ha: Cardinal;
+begin
+ ha := TSuperAvlEntry.Hash(k);
+ h := FTree.FRoot;
+ d := 0;
+ FDepth := not 0;
+ if (h = nil) then
+ exit;
+
+ if (stLess in st) then
+ target_cmp := 1 else
+ if (stGreater in st) then
+ target_cmp := -1 else
+ target_cmp := 0;
+
+ while true do
+ begin
+ if h.FHash < ha then cmp := -1 else
+ if h.FHash > ha then cmp := 1 else
+ cmp := 0;
+
+ if cmp = 0 then
+ cmp := FTree.CompareKeyNode(k, h);
+ if (cmp = 0) then
+ begin
+ if (stEqual in st) then
+ begin
+ FDepth := d;
+ break;
+ end;
+ cmp := -target_cmp;
+ end
+ else
+ if (target_cmp <> 0) then
+ if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then
+ FDepth := d;
+ if cmp < 0 then
+ h := h.FLt else
+ h := h.FGt;
+ if (h = nil) then
+ break;
+ if (cmp > 0) then
+ include(FBranch, d) else
+ exclude(FBranch, d);
+ FPath[d] := h;
+ inc(d);
+ end;
+end;
+
+procedure TSuperAvlIterator.First;
+var
+ h: TSuperAvlEntry;
+begin
+ h := FTree.FRoot;
+ FDepth := not 0;
+ FBranch := [];
+ while (h <> nil) do
+ begin
+ if (FDepth <> not 0) then
+ FPath[FDepth] := h;
+ inc(FDepth);
+ h := h.FLt;
+ end;
+end;
+
+procedure TSuperAvlIterator.Last;
+var
+ h: TSuperAvlEntry;
+begin
+ h := FTree.FRoot;
+ FDepth := not 0;
+ FBranch := [0..SUPER_AVL_MAX_DEPTH - 1];
+ while (h <> nil) do
+ begin
+ if (FDepth <> not 0) then
+ FPath[FDepth] := h;
+ inc(FDepth);
+ h := h.FGt;
+ end;
+end;
+
+function TSuperAvlIterator.MoveNext: boolean;
+begin
+ if FDepth = not 0 then
+ First else
+ Next;
+ Result := GetIter <> nil;
+end;
+
+function TSuperAvlIterator.GetIter: TSuperAvlEntry;
+begin
+ if (FDepth = not 0) then
+ begin
+ result := nil;
+ exit;
+ end;
+ if FDepth = 0 then
+ Result := FTree.FRoot else
+ Result := FPath[FDepth - 1];
+end;
+
+procedure TSuperAvlIterator.Next;
+var
+ h: TSuperAvlEntry;
+begin
+ if (FDepth <> not 0) then
+ begin
+ if FDepth = 0 then
+ h := FTree.FRoot.FGt else
+ h := FPath[FDepth - 1].FGt;
+
+ if (h = nil) then
+ repeat
+ if (FDepth = 0) then
+ begin
+ FDepth := not 0;
+ break;
+ end;
+ dec(FDepth);
+ until (not (FDepth in FBranch))
+ else
+ begin
+ include(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ while true do
+ begin
+ h := h.FLt;
+ if (h = nil) then
+ break;
+ exclude(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ end;
+ end;
+ end;
+end;
+
+procedure TSuperAvlIterator.Prior;
+var
+ h: TSuperAvlEntry;
+begin
+ if (FDepth <> not 0) then
+ begin
+ if FDepth = 0 then
+ h := FTree.FRoot.FLt else
+ h := FPath[FDepth - 1].FLt;
+ if (h = nil) then
+ repeat
+ if (FDepth = 0) then
+ begin
+ FDepth := not 0;
+ break;
+ end;
+ dec(FDepth);
+ until (FDepth in FBranch)
+ else
+ begin
+ exclude(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ while true do
+ begin
+ h := h.FGt;
+ if (h = nil) then
+ break;
+ include(FBranch, FDepth);
+ FPath[FDepth] := h;
+ inc(FDepth);
+ end;
+ end;
+ end;
+end;
+
+procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
+begin
+ Entry.Free;
+end;
+
+function TSuperAvlTree.GetEnumerator: TSuperAvlIterator;
+begin
+ Result := TSuperAvlIterator.Create(Self);
+end;
+
+{ TSuperAvlEntry }
+
+constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer);
+begin
+ FName := AName;
+ FPtr := Obj;
+ FHash := Hash(FName);
+end;
+
+function TSuperAvlEntry.GetValue: ISuperObject;
+begin
+ Result := ISuperObject(FPtr)
+end;
+
+class function TSuperAvlEntry.Hash(const k: SOString): Cardinal;
+var
+ h: cardinal;
+ i: Integer;
+begin
+ h := 0;
+{$Q-}
+ for i := 1 to Length(k) do
+ h := h*129 + ord(k[i]) + $9e370001;
+{$Q+}
+ Result := h;
+end;
+
+procedure TSuperAvlEntry.SetValue(const val: ISuperObject);
+begin
+ ISuperObject(FPtr) := val;
+end;
+
+{ TSuperTableString }
+
+function TSuperTableString.GetValues: ISuperObject;
+var
+ ite: TSuperAvlIterator;
+ obj: TSuperAvlEntry;
+begin
+ Result := TSuperObject.Create(stArray);
+ ite := TSuperAvlIterator.Create(Self);
+ try
+ ite.First;
+ obj := ite.GetIter;
+ while obj <> nil do
+ begin
+ Result.AsArray.Add(obj.Value);
+ ite.Next;
+ obj := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+end;
+
+function TSuperTableString.GetNames: ISuperObject;
+var
+ ite: TSuperAvlIterator;
+ obj: TSuperAvlEntry;
+begin
+ Result := TSuperObject.Create(stArray);
+ ite := TSuperAvlIterator.Create(Self);
+ try
+ ite.First;
+ obj := ite.GetIter;
+ while obj <> nil do
+ begin
+ Result.AsArray.Add(TSuperObject.Create(obj.FName));
+ ite.Next;
+ obj := ite.GetIter;
+ end;
+ finally
+ ite.Free;
+ end;
+end;
+
+procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean);
+begin
+ if Entry.Ptr <> nil then
+ begin
+ if all then Entry.Value.Clear(true);
+ Entry.Value := nil;
+ end;
+ inherited;
+end;
+
+function TSuperTableString.GetO(const k: SOString): ISuperObject;
+var
+ e: TSuperAvlEntry;
+begin
+ e := Search(k);
+ if e <> nil then
+ Result := e.Value else
+ Result := nil
+end;
+
+procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject);
+var
+ entry: TSuperAvlEntry;
+begin
+ entry := Insert(TSuperAvlEntry.Create(k, Pointer(value)));
+ if entry.FPtr <> nil then
+ ISuperObject(entry.FPtr)._AddRef;
+end;
+
+procedure TSuperTableString.PutS(const k: SOString; const value: SOString);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+function TSuperTableString.GetS(const k: SOString): SOString;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsString else
+ Result := '';
+end;
+
+procedure TSuperTableString.PutI(const k: SOString; value: SuperInt);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+function TSuperTableString.GetI(const k: SOString): SuperInt;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsInteger else
+ Result := 0;
+end;
+
+procedure TSuperTableString.PutD(const k: SOString; value: Double);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+procedure TSuperTableString.PutC(const k: SOString; value: Currency);
+begin
+ PutO(k, TSuperObject.CreateCurrency(Value));
+end;
+
+function TSuperTableString.GetC(const k: SOString): Currency;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsCurrency else
+ Result := 0.0;
+end;
+
+function TSuperTableString.GetD(const k: SOString): Double;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsDouble else
+ Result := 0.0;
+end;
+
+procedure TSuperTableString.PutB(const k: SOString; value: Boolean);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+
+function TSuperTableString.GetB(const k: SOString): Boolean;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsBoolean else
+ Result := False;
+end;
+
+{$IFDEF SUPER_METHOD}
+procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod);
+begin
+ PutO(k, TSuperObject.Create(Value));
+end;
+{$ENDIF}
+
+{$IFDEF SUPER_METHOD}
+function TSuperTableString.GetM(const k: SOString): TSuperMethod;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj.AsMethod else
+ Result := nil;
+end;
+{$ENDIF}
+
+procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject);
+begin
+ if value <> nil then
+ PutO(k, TSuperObject.Create(stNull)) else
+ PutO(k, value);
+end;
+
+function TSuperTableString.GetN(const k: SOString): ISuperObject;
+var
+ obj: ISuperObject;
+begin
+ obj := GetO(k);
+ if obj <> nil then
+ Result := obj else
+ Result := TSuperObject.Create(stNull);
+end;
+
+
+{$IFDEF VER210}
+
+{ TSuperAttribute }
+
+constructor TSuperAttribute.Create(const AName: string);
+begin
+ FName := AName;
+end;
+
+{ TSuperRttiContext }
+
+constructor TSuperRttiContext.Create;
+begin
+ Context := TRttiContext.Create;
+ SerialFromJson := TDictionary.Create;
+ SerialToJson := TDictionary.Create;
+
+ SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean);
+ SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime);
+ SerialFromJson.Add(TypeInfo(TGUID), serialfromguid);
+ SerialToJson.Add(TypeInfo(Boolean), serialtoboolean);
+ SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime);
+ SerialToJson.Add(TypeInfo(TGUID), serialtoguid);
+end;
+
+destructor TSuperRttiContext.Destroy;
+begin
+ SerialFromJson.Free;
+ SerialToJson.Free;
+ Context.Free;
+end;
+
+class function TSuperRttiContext.GetFieldName(r: TRttiField): string;
+var
+ o: TCustomAttribute;
+begin
+ for o in r.GetAttributes do
+ if o is SOName then
+ Exit(SOName(o).Name);
+ Result := r.Name;
+end;
+
+class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject;
+var
+ o: TCustomAttribute;
+begin
+ if not ObjectIsType(obj, stNull) then Exit(obj);
+ for o in r.GetAttributes do
+ if o is SODefault then
+ Exit(SO(SODefault(o).Name));
+ Result := obj;
+end;
+
+function TSuperRttiContext.AsType(const obj: ISuperObject): T;
+var
+ ret: TValue;
+begin
+ if FromJson(TypeInfo(T), obj, ret) then
+ Result := ret.AsType else
+ raise exception.Create('Marshalling error');
+end;
+
+function TSuperRttiContext.AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject;
+var
+ v: TValue;
+begin
+ TValue.MakeWithoutCopy(@obj, TypeInfo(T), v);
+ if index <> nil then
+ Result := ToJson(v, index) else
+ Result := ToJson(v, so);
+end;
+
+function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject;
+ var Value: TValue): Boolean;
+
+ procedure FromChar;
+ begin
+ if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
+ begin
+ Value := string(AnsiString(obj.AsString)[1]);
+ Result := True;
+ end else
+ Result := False;
+ end;
+
+ procedure FromWideChar;
+ begin
+ if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then
+ begin
+ Value := obj.AsString[1];
+ Result := True;
+ end else
+ Result := False;
+ end;
+
+ procedure FromInt64;
+ var
+ i: Int64;
+ begin
+ case ObjectGetType(obj) of
+ stInt:
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ TValueData(Value).FAsSInt64 := obj.AsInteger;
+ Result := True;
+ end;
+ stString:
+ begin
+ if TryStrToInt64(obj.AsString, i) then
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ TValueData(Value).FAsSInt64 := i;
+ Result := True;
+ end else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ end;
+
+ procedure FromInt(const obj: ISuperObject);
+ var
+ TypeData: PTypeData;
+ i: Integer;
+ o: ISuperObject;
+ begin
+ case ObjectGetType(obj) of
+ stInt, stBoolean:
+ begin
+ i := obj.AsInteger;
+ TypeData := GetTypeData(TypeInfo);
+ Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue);
+ if Result then
+ TValue.Make(@i, TypeInfo, Value);
+ end;
+ stString:
+ begin
+ o := SO(obj.AsString);
+ if not ObjectIsType(o, stString) then
+ FromInt(o) else
+ Result := False;
+ end;
+ else
+ Result := False;
+ end;
+ end;
+
+ procedure fromSet;
+ begin
+ if ObjectIsType(obj, stInt) then
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ TValueData(Value).FAsSLong := obj.AsInteger;
+ Result := True;
+ end else
+ Result := False;
+ end;
+
+ procedure FromFloat(const obj: ISuperObject);
+ var
+ o: ISuperObject;
+ begin
+ case ObjectGetType(obj) of
+ stInt, stDouble, stCurrency:
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ case GetTypeData(TypeInfo).FloatType of
+ ftSingle: TValueData(Value).FAsSingle := obj.AsDouble;
+ ftDouble: TValueData(Value).FAsDouble := obj.AsDouble;
+ ftExtended: TValueData(Value).FAsExtended := obj.AsDouble;
+ ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger;
+ ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency;
+ end;
+ Result := True;
+ end;
+ stString:
+ begin
+ o := SO(obj.AsString);
+ if not ObjectIsType(o, stString) then
+ FromFloat(o) else
+ Result := False;
+ end
+ else
+ Result := False;
+ end;
+ end;
+
+ procedure FromString;
+ begin
+ case ObjectGetType(obj) of
+ stObject, stArray:
+ Result := False;
+ stnull:
+ begin
+ Value := '';
+ Result := True;
+ end;
+ else
+ Value := obj.AsString;
+ Result := True;
+ end;
+ end;
+
+ procedure FromClass;
+ var
+ f: TRttiField;
+ v: TValue;
+ begin
+ case ObjectGetType(obj) of
+ stObject:
+ begin
+ Result := True;
+ if Value.Kind <> tkClass then
+ Value := GetTypeData(TypeInfo).ClassType.Create;
+ for f in Context.GetType(Value.AsObject.ClassType).GetFields do
+ if f.FieldType <> nil then
+ begin
+ Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
+ if Result then
+ f.SetValue(Value.AsObject, v) else
+ Exit;
+ end;
+ end;
+ stNull:
+ begin
+ Value := nil;
+ Result := True;
+ end
+ else
+ // error
+ Value := nil;
+ Result := False;
+ end;
+ end;
+
+ procedure FromRecord;
+ var
+ f: TRttiField;
+ p: Pointer;
+ v: TValue;
+ begin
+ Result := True;
+ TValue.Make(nil, TypeInfo, Value);
+ for f in Context.GetType(TypeInfo).GetFields do
+ begin
+ if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then
+ begin
+ p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData;
+ Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v);
+ if Result then
+ f.SetValue(p, v) else
+ Exit;
+ end else
+ begin
+ Result := False;
+ Exit;
+ end;
+ end;
+ end;
+
+ procedure FromDynArray;
+ var
+ i: Integer;
+ p: Pointer;
+ pb: PByte;
+ val: TValue;
+ typ: PTypeData;
+ el: PTypeInfo;
+ begin
+ case ObjectGetType(obj) of
+ stArray:
+ begin
+ i := obj.AsArray.Length;
+ p := nil;
+ DynArraySetLength(p, TypeInfo, 1, @i);
+ pb := p;
+ typ := GetTypeData(TypeInfo);
+ if typ.elType <> nil then
+ el := typ.elType^ else
+ el := typ.elType2^;
+
+ Result := True;
+ for i := 0 to i - 1 do
+ begin
+ Result := FromJson(el, obj.AsArray[i], val);
+ if not Result then
+ Break;
+ val.ExtractRawData(pb);
+ val := TValue.Empty;
+ Inc(pb, typ.elSize);
+ end;
+ if Result then
+ TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
+ DynArrayClear(p, TypeInfo);
+ end;
+ stNull:
+ begin
+ TValue.MakeWithoutCopy(nil, TypeInfo, Value);
+ Result := True;
+ end;
+ else
+ i := 1;
+ p := nil;
+ DynArraySetLength(p, TypeInfo, 1, @i);
+ pb := p;
+ typ := GetTypeData(TypeInfo);
+ if typ.elType <> nil then
+ el := typ.elType^ else
+ el := typ.elType2^;
+
+ Result := FromJson(el, obj, val);
+ val.ExtractRawData(pb);
+ val := TValue.Empty;
+
+ if Result then
+ TValue.MakeWithoutCopy(@p, TypeInfo, Value) else
+ DynArrayClear(p, TypeInfo);
+ end;
+ end;
+
+ procedure FromArray;
+ var
+ ArrayData: PArrayTypeData;
+ idx: Integer;
+ function ProcessDim(dim: Byte; const o: ISuperobject): Boolean;
+ var
+ i: Integer;
+ v: TValue;
+ a: PTypeData;
+ begin
+ if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then
+ begin
+ a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData;
+ if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then
+ begin
+ Result := False;
+ Exit;
+ end;
+ Result := True;
+ if dim = ArrayData.DimCount then
+ for i := a.MinValue to a.MaxValue do
+ begin
+ Result := FromJson(ArrayData.ElType^, o.AsArray[i], v);
+ if not Result then
+ Exit;
+ Value.SetArrayElement(idx, v);
+ inc(idx);
+ end
+ else
+ for i := a.MinValue to a.MaxValue do
+ begin
+ Result := ProcessDim(dim + 1, o.AsArray[i]);
+ if not Result then
+ Exit;
+ end;
+ end else
+ Result := False;
+ end;
+ var
+ i: Integer;
+ v: TValue;
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ ArrayData := @GetTypeData(TypeInfo).ArrayData;
+ idx := 0;
+ if ArrayData.DimCount = 1 then
+ begin
+ if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then
+ begin
+ Result := True;
+ for i := 0 to ArrayData.ElCount - 1 do
+ begin
+ Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v);
+ if not Result then
+ Exit;
+ Value.SetArrayElement(idx, v);
+ v := TValue.Empty;
+ inc(idx);
+ end;
+ end else
+ Result := False;
+ end else
+ Result := ProcessDim(1, obj);
+ end;
+
+ procedure FromClassRef;
+ var
+ r: TRttiType;
+ begin
+ if ObjectIsType(obj, stString) then
+ begin
+ r := Context.FindType(obj.AsString);
+ if r <> nil then
+ begin
+ Value := TRttiInstanceType(r).MetaclassType;
+ Result := True;
+ end else
+ Result := False;
+ end else
+ Result := False;
+ end;
+
+ procedure FromUnknown;
+ begin
+ case ObjectGetType(obj) of
+ stBoolean:
+ begin
+ Value := obj.AsBoolean;
+ Result := True;
+ end;
+ stDouble:
+ begin
+ Value := obj.AsDouble;
+ Result := True;
+ end;
+ stCurrency:
+ begin
+ Value := obj.AsCurrency;
+ Result := True;
+ end;
+ stInt:
+ begin
+ Value := obj.AsInteger;
+ Result := True;
+ end;
+ stString:
+ begin
+ Value := obj.AsString;
+ Result := True;
+ end
+ else
+ Value := nil;
+ Result := False;
+ end;
+ end;
+
+ procedure FromInterface;
+ const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}';
+ var
+ o: ISuperObject;
+ begin
+ if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then
+ begin
+ if obj <> nil then
+ TValue.Make(@obj, TypeInfo, Value) else
+ begin
+ o := TSuperObject.Create(stNull);
+ TValue.Make(@o, TypeInfo, Value);
+ end;
+ Result := True;
+ end else
+ Result := False;
+ end;
+var
+ Serial: TSerialFromJson;
+begin
+ if TypeInfo <> nil then
+ begin
+ if not SerialFromJson.TryGetValue(TypeInfo, Serial) then
+ case TypeInfo.Kind of
+ tkChar: FromChar;
+ tkInt64: FromInt64;
+ tkEnumeration, tkInteger: FromInt(obj);
+ tkSet: fromSet;
+ tkFloat: FromFloat(obj);
+ tkString, tkLString, tkUString, tkWString: FromString;
+ tkClass: FromClass;
+ tkMethod: ;
+ tkWChar: FromWideChar;
+ tkRecord: FromRecord;
+ tkPointer: ;
+ tkInterface: FromInterface;
+ tkArray: FromArray;
+ tkDynArray: FromDynArray;
+ tkClassRef: FromClassRef;
+ else
+ FromUnknown
+ end else
+ begin
+ TValue.Make(nil, TypeInfo, Value);
+ Result := Serial(Self, obj, Value);
+ end;
+ end else
+ Result := False;
+end;
+
+function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject;
+ procedure ToInt64;
+ begin
+ Result := TSuperObject.Create(SuperInt(Value.AsInt64));
+ end;
+
+ procedure ToChar;
+ begin
+ Result := TSuperObject.Create(string(Value.AsType));
+ end;
+
+ procedure ToInteger;
+ begin
+ Result := TSuperObject.Create(TValueData(Value).FAsSLong);
+ end;
+
+ procedure ToFloat;
+ begin
+ case Value.TypeData.FloatType of
+ ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle);
+ ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble);
+ ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended);
+ ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64);
+ ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr);
+ end;
+ end;
+
+ procedure ToString;
+ begin
+ Result := TSuperObject.Create(string(Value.AsType));
+ end;
+
+ procedure ToClass;
+ var
+ o: ISuperObject;
+ f: TRttiField;
+ v: TValue;
+ begin
+ if TValueData(Value).FAsObject <> nil then
+ begin
+ o := index[IntToStr(Integer(Value.AsObject))];
+ if o = nil then
+ begin
+ Result := TSuperObject.Create(stObject);
+ index[IntToStr(Integer(Value.AsObject))] := Result;
+ for f in Context.GetType(Value.AsObject.ClassType).GetFields do
+ if f.FieldType <> nil then
+ begin
+ v := f.GetValue(Value.AsObject);
+ Result.AsObject[GetFieldName(f)] := ToJson(v, index);
+ end
+ end else
+ Result := o;
+ end else
+ Result := nil;
+ end;
+
+ procedure ToWChar;
+ begin
+ Result := TSuperObject.Create(string(Value.AsType));
+ end;
+
+ procedure ToVariant;
+ begin
+ Result := SO(Value.AsVariant);
+ end;
+
+ procedure ToRecord;
+ var
+ f: TRttiField;
+ v: TValue;
+ begin
+ Result := TSuperObject.Create(stObject);
+ for f in Context.GetType(Value.TypeInfo).GetFields do
+ begin
+ v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData);
+ Result.AsObject[GetFieldName(f)] := ToJson(v, index);
+ end;
+ end;
+
+ procedure ToArray;
+ var
+ idx: Integer;
+ ArrayData: PArrayTypeData;
+
+ procedure ProcessDim(dim: Byte; const o: ISuperObject);
+ var
+ dt: PTypeData;
+ i: Integer;
+ o2: ISuperObject;
+ v: TValue;
+ begin
+ if ArrayData.Dims[dim-1] = nil then Exit;
+ dt := GetTypeData(ArrayData.Dims[dim-1]^);
+ if Dim = ArrayData.DimCount then
+ for i := dt.MinValue to dt.MaxValue do
+ begin
+ v := Value.GetArrayElement(idx);
+ o.AsArray.Add(toJSon(v, index));
+ inc(idx);
+ end
+ else
+ for i := dt.MinValue to dt.MaxValue do
+ begin
+ o2 := TSuperObject.Create(stArray);
+ o.AsArray.Add(o2);
+ ProcessDim(dim + 1, o2);
+ end;
+ end;
+ var
+ i: Integer;
+ v: TValue;
+ begin
+ Result := TSuperObject.Create(stArray);
+ ArrayData := @Value.TypeData.ArrayData;
+ idx := 0;
+ if ArrayData.DimCount = 1 then
+ for i := 0 to ArrayData.ElCount - 1 do
+ begin
+ v := Value.GetArrayElement(i);
+ Result.AsArray.Add(toJSon(v, index))
+ end
+ else
+ ProcessDim(1, Result);
+ end;
+
+ procedure ToDynArray;
+ var
+ i: Integer;
+ v: TValue;
+ begin
+ Result := TSuperObject.Create(stArray);
+ for i := 0 to Value.GetArrayLength - 1 do
+ begin
+ v := Value.GetArrayElement(i);
+ Result.AsArray.Add(toJSon(v, index));
+ end;
+ end;
+
+ procedure ToClassRef;
+ begin
+ if TValueData(Value).FAsClass <> nil then
+ Result := TSuperObject.Create(string(
+ TValueData(Value).FAsClass.UnitName + '.' +
+ TValueData(Value).FAsClass.ClassName)) else
+ Result := nil;
+ end;
+
+ procedure ToInterface;
+ begin
+ if TValueData(Value).FHeapData <> nil then
+ TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else
+ Result := nil;
+ end;
+
+var
+ Serial: TSerialToJson;
+begin
+ if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then
+ case Value.Kind of
+ tkInt64: ToInt64;
+ tkChar: ToChar;
+ tkSet, tkInteger, tkEnumeration: ToInteger;
+ tkFloat: ToFloat;
+ tkString, tkLString, tkUString, tkWString: ToString;
+ tkClass: ToClass;
+ tkWChar: ToWChar;
+ tkVariant: ToVariant;
+ tkRecord: ToRecord;
+ tkArray: ToArray;
+ tkDynArray: ToDynArray;
+ tkClassRef: ToClassRef;
+ tkInterface: ToInterface;
+ else
+ result := nil;
+ end else
+ Result := Serial(Self, value, index);
+end;
+
+{ TSuperObjectHelper }
+
+constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil);
+var
+ v: TValue;
+ ctxowned: Boolean;
+begin
+ if ctx = nil then
+ begin
+ ctx := TSuperRttiContext.Create;
+ ctxowned := True;
+ end else
+ ctxowned := False;
+ try
+ v := Self;
+ if not ctx.FromJson(v.TypeInfo, obj, v) then
+ raise Exception.Create('Invalid object');
+ finally
+ if ctxowned then
+ ctx.Free;
+ end;
+end;
+
+constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil);
+begin
+ FromJson(SO(str), ctx);
+end;
+
+function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject;
+var
+ v: TValue;
+ ctxowned: boolean;
+begin
+ if ctx = nil then
+ begin
+ ctx := TSuperRttiContext.Create;
+ ctxowned := True;
+ end else
+ ctxowned := False;
+ try
+ v := Self;
+ Result := ctx.ToJson(v, SO);
+ finally
+ if ctxowned then
+ ctx.Free;
+ end;
+end;
+
+{$ENDIF}
+
+{$IFDEF DEBUG}
+initialization
+
+finalization
+ Assert(debugcount = 0, 'Memory leak');
+{$ENDIF}
+end.
+
diff --git "a/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/uJSON.pas" "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/uJSON.pas"
new file mode 100644
index 0000000..4ccdf95
--- /dev/null
+++ "b/demo/YxdJson/JSON\346\200\247\350\203\275\345\257\271\346\257\224\346\265\213\350\257\225/uJSON.pas"
@@ -0,0 +1,4389 @@
+{
+ Copyright (C) 2005 Fabio Almeida
+ fabiorecife@yahoo.com.br
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ Autor : Jose Fabio Nascimento de Almeida
+ Data : 7/11/2005
+
+
+Change Logs:
+2013-11-04 By yangyxd
+ parent, child֧֡int64֧
+
+2009-11-22 By creation_zy
+ Can parse #10 #13 inside a string.
+ JSONObject.quote method can deal with special character smaller than space.
+ Value inside a _String object can Read/Write directly.
+
+2011-09-02 By creation_zy
+ Add _Object to store common Object.
+
+2011-09-20 By creation_zy
+ Add SafeFreeJObj.
+ Add "inline" directive.
+
+2011-12-15 By creation_zy
+ Add SpaceStr function to optimize toString3.
+}
+unit uJSON;
+
+interface
+
+uses
+ Windows,SysUtils, Classes, TypInfo;
+
+{$DEFINE J_OBJECT} // store common Object
+{$IF COMPILERVERSION>=18}{$DEFINE INLINE_OPT}{$IFEND}
+{$DEFINE BACK_OPT}
+{$DEFINE NEXT_OPT}
+
+
+Type
+ JSONArray = class ;
+ JSONBase = class;
+ JSONObject = class;
+
+ TZAbstractObject = class (TObject)
+ class procedure WriteChar(avOut: TStream; const avData: Char);
+ class procedure WriteString(avOut: TStream; const avData: string);
+ class procedure WriteText(avOut: TStream; const avData: string; len: Integer);
+
+ function Equals(const Value: TZAbstractObject): Boolean; virtual;
+ function Hash: LongInt;
+ function Clone: TZAbstractObject; virtual;
+ function toString: string; virtual;
+ function toJSONObject: JSONObject;
+ function toJSONArray: JSONArray;
+ function instanceOf(const Value: TZAbstractObject): Boolean;
+ procedure SaveToStream(stream: TStream); virtual;
+ class function getInt(o: TZAbstractObject; DefaultValue: Integer):Integer;
+ class function getInt64(o: TZAbstractObject; DefaultValue: Int64): Int64;
+ class function getDouble(o: TZAbstractObject; DefaultValue: Double):Double;
+ class function getBoolean(o: TZAbstractObject; DefaultValue: Boolean):Boolean;
+ procedure Free; overload; //2011-10-10 Call SafeFreeJObj
+ end;
+
+ ClassCastException = class (Exception) end;
+ NoSuchElementException = class (Exception) end;
+ NumberFormatException = class (Exception) end;
+ NullPointerException = class (Exception) end;
+ NotImplmentedFeature = class (Exception) end;
+ _Number = class ;
+ _String = class;
+ _Double = class;
+ _NULL = class ;
+{$IFDEF J_OBJECT}
+ _Object = class; //2011-08-09
+{$ENDIF}
+
+
+ ParseException = class (Exception)
+ constructor create (_message: string ; index: integer);
+ end;
+ JSONTokener = class (TZAbstractObject)
+ public
+ constructor create (const s: string);
+ procedure back();{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ class function dehexchar(c: char) :integer;
+ function more :boolean;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function next(): char; overload ;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function next (c:char ): char; overload ;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function next (n:integer): string; overload ;{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function nextClean (): char;//{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function nextString (quote: char): string;//{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ function nextTo (d: char): string; overload ;
+ function nextTo (const delimiters: string): char; overload ;
+ function nextValue (parent: JSONBase): TZAbstractObject ;//{$IFDEF INLINE_OPT}inline;{$ENDIF}
+ procedure skipPast (const _to: string ) ;
+ function skipTo (_to: char ): char;
+ function syntaxError (const _message: string): ParseException;
+ function toString: string; override;
+ function unescape (const s: string): string;
+ private
+ myIndex, Len1: integer;
+ mySource: string;
+ end;
+
+ // by yangyxd 2013.11.04
+ JSONBase = class(TZAbstractObject)
+ private
+ FParent: JSONBase;
+ FName: string;
+ protected
+ function GetCount: Integer; virtual;
+ function GetChild(Index: Integer): TZAbstractObject; virtual;
+ procedure SetChild(Index: Integer; const Value: TZAbstractObject); virtual;
+ public
+ constructor Create;
+ function IndexOfObject(aobj: TObject): Integer; virtual;
+ property Count: Integer read GetCount;
+ property Parent: JSONBase read FParent write FParent;
+ property Name: string read FName write FName;
+ property Child[Index: Integer]: TZAbstractObject read GetChild write SetChild;
+ end;
+
+ JSONObject = class (JSONBase)
+ private
+ myHashMap: TStringList;
+ function GetPropValues(const Key: String): String;
+ procedure SetPropValues(const Key: String; const Value: String);
+ procedure SetAsString(const Value: String);
+ function GetKeyByIndex(index: Integer): String;
+ procedure SetCascadeValueEx(const Value: String; const Keys: array of String;
+ StartIdx: Integer);
+ function GetValByIndex(index: Integer): String;
+ procedure UpdateByTokener(x: JSONTokener);
+ function GetValObjByIndex(index: Integer): TZAbstractObject;
+ protected
+ function GetCount: Integer; override; // by yangyxd
+ function GetChild(Index: Integer): TZAbstractObject; override; // by yangyxd
+ procedure SetChild(Index: Integer; const Value: TZAbstractObject); override; // by yangyxd
+ public
+ constructor Create; overload;
+ constructor Create (jo: JSONObject; sa: array of string); overload;
+ constructor Create (x: JSONTokener); overload;
+ constructor Create (map: TStringList); overload;
+ constructor Create (const s: string); overload;
+ constructor CreateInArray(Ay: JSONArray);
+
+ function IndexOfObject(aobj: TObject): Integer; override; // by yangyxd
+
+ procedure Clean;
+ function Clone: TZAbstractObject; override;
+ function Accumulate (const key: string; value: TZAbstractObject): JSONObject;
+ function Get (const key: string): TZAbstractObject;
+ function GetBoolean (const key: string): boolean;
+ function GetDouble (const key: string): double;
+ function GetInt (const key: string): integer;
+ function GetInt64 (const key: string): Int64;
+ function GetJSONArray (const key: string) :JSONArray;
+ function GetJSONObject (const key: string): JSONObject;
+ function GetString (const key: string): string;
+ function Has (const key: string): boolean;
+ function IsNull (const key: string): boolean;
+ function Keys: TStringList ;
+ function Length: integer;
+ function Names: JSONArray;
+ class function NumberToString (n: _Number): string;
+ class function ValueToString(value: TZAbstractObject): string; overload;
+ class procedure ValueToStream(value: TZAbstractObject; stream: TStream); overload;
+ class function ValueToString(value: TZAbstractObject;
+ indentFactor, indent: integer): string; overload;
+
+ function NextSibling: JSONObject;
+ function UpSibling: JSONObject;
+
+ function Opt (const key: string): TZAbstractObject;
+ function OptBoolean (const key: string): boolean; overload;
+ function OptBoolean (const key: string; defaultValue: boolean): boolean; overload;
+ function OptDouble (const key: string): double; overload;
+ function OptDouble (const key: string; defaultValue: double): double; overload;
+ function OptInt (const key: string): integer; overload;
+ function OptInt (const key: string; defaultValue: integer): integer; overload;
+ function OptInt64 (const key: string): int64; overload;
+ function OptInt64 (const key: string; defaultValue: int64): int64; overload;
+ function OptString (const key: string): string; overload;
+ function OptString (const key, defaultValue: string): string; overload;
+
+ function OptJSONArray (const key: string): JSONArray; overload;
+ function OptJSONObject (const key: string): JSONObject; overload;
+
+ function Put (const key: string; value: boolean): JSONObject; overload;
+ function Put (const key: string; value: double): JSONObject; overload;
+ function Put (const key: string; value: integer): JSONObject; overload;
+ function Put (const key: string; value: int64): JSONObject; overload;
+ function Put (const key: string; const value: string): JSONObject; overload;
+ function Put (const key: string; value: TZAbstractObject): JSONObject; overload;
+
+ function PutOpt (const key: string; value: TZAbstractObject): JSONObject;
+ class function quote (const s: string): string;
+ class procedure quoteToStream (stream: TStream; const s: string);
+ function Remove (const key: string): TZAbstractObject;
+ procedure AssignTo(json: JSONObject);
+
+ function ToJSONArray (names: JSONArray): JSONArray;
+ function toString (): string ; overload; override;
+ function toString2 (indentFactor: integer): string; overload;
+ function toString3 (indentFactor, indent: integer): string; overload;
+
+ procedure SaveToStream(stream: TStream); override;
+
+ //Add by creation_zy 2008-10-21
+ property PropValues[const Key: String]:String read GetPropValues write SetPropValues; default;
+ property KeyByIndex[index: Integer]:String read GetKeyByIndex;
+ property ValByIndex[index: Integer]:String read GetValByIndex;
+ property ValObjByIndex[index: Integer]:TZAbstractObject read GetValObjByIndex;
+ property AsString:String read ToString write SetAsString;
+ procedure Assign(Source: JSONObject);
+ function Opt2(key, key2: string): TZAbstractObject;
+ function OptString2(key, key2: String; DefaultValue: String=''): String;
+ function OptInt2(key, key2: String; DefaultValue: Integer=0): Integer;
+ function GetCascadeValue(const Keys: array of String): String;
+ procedure SetCascadeValue(const Value: String; const Keys: array of String);
+ function GetCascadeValEx(const Keys: array of String): String;
+ function GetCascadeValObj(const Keys: array of String): TZAbstractObject;
+ function GetDiffFrom(Source: JSONObject; UseSrc: Boolean=true):JSONObject;
+ procedure Delete(index: Integer);
+ procedure RemoveByKeyHeader(const Header: String='~');
+ function RemoveLastKey:TZAbstractObject;
+ procedure CleanKey(const Key: String);
+ function SetKey(idx: Integer; const Key: String):Boolean;
+ function PropCount:Integer;
+ function KeyByVal(const Value: String):String;
+ function PartExtract(KeyNames: TStrings; DoRemove: Boolean):JSONObject;
+ function ExtractAll:JSONObject;
+ function TryNewJSONArray(const Key: String):JSONArray;
+ function TryNewJSONObject(const Key: String):JSONObject;
+ //Add by creation_zy 2011-08-09
+ {$IFDEF J_OBJECT}
+ function GetObject (const key: string): TObject;
+ function OptObject (const key: string): TObject; overload;
+ function OptObject (const key: string; defaultValue: TObject): TObject; overload;
+ function Put (const key: string; value: TObject): JSONObject; overload;
+ {$ENDIF}
+
+ destructor Destroy;override;
+ class function NULL: _NULL;
+ end;
+
+ JSONArray = class (JSONBase)
+ public
+ destructor Destroy ; override;
+ constructor Create ; overload;
+ constructor Create (collection: TList); overload;
+ constructor Create (x: JSONTokener); overload;
+ constructor Create (const s: string); overload;
+
+ procedure Clean; //by creation_zy 2009-08-19
+ function Clone: TZAbstractObject; override; //by creation_zy 2008-10-05
+ function get (index: integer): TZAbstractObject;
+ function getBoolean (index: integer): boolean;
+ function getDouble (index: integer): double;
+ function getInt (index: integer): integer;
+ function getInt64 (index: integer): int64;
+ function getJSONArray (index: integer): JSONArray;
+ function getJSONObject (index: integer): JSONObject;
+ function getString (index: integer): string;
+ function isNull (index: integer): boolean;
+ function join (separator: string): string;
+ function length: integer;
+ function opt (index: integer): TZAbstractObject;
+ function optBoolean ( index: integer): boolean; overload;
+ function optBoolean ( index: integer; defaultValue: boolean): boolean; overload;
+ function optDouble (index: integer): double; overload;
+ function optDouble (index: integer; defaultValue :double ): double ; overload;
+ function optInt (index: integer): integer; overload;
+ function optInt (index: integer; defaultValue: integer): integer; overload;
+ function OptInt64 (index: integer): int64; overload;
+ function OptInt64 (index: integer; defaultValue: int64): int64; overload;
+ function optJSONArray (index: integer): JSONArray ; overload;
+ function optJSONObject (index: integer): JSONObject ; overload;
+ function optString (index: integer): string; overload;
+ function optString (index: integer; defaultValue: string): string; overload;
+ {$IFDEF J_OBJECT}
+ function optObject (index: integer): TObject; overload;
+ {$ENDIF}
+ function put ( value: boolean): JSONArray; overload ;
+ function put ( value: double ): JSONArray; overload ;
+ function put ( value: integer): JSONArray; overload ;
+ function put ( value: TZAbstractObject): JSONArray; overload ;
+ function put ( value: string): JSONArray; overload;
+ {$IFDEF J_OBJECT}
+ function put ( value: TObject): JSONArray; overload;
+ {$ENDIF}
+ function put ( index: integer ; value: boolean): JSONArray; overload ;
+ function put ( index: integer ; value: double): JSONArray; overload ;
+ function put ( index: integer ; value: integer): JSONArray; overload ;
+ function put ( index: integer ; value: int64): JSONArray; overload ;
+ function put ( index: integer ; value: TZAbstractObject): JSONArray; overload ;
+ function put ( index: integer; value: string): JSONArray; overload;
+ {$IFDEF J_OBJECT}
+ function put ( index: integer ; value: TObject): JSONArray; overload;
+ {$ENDIF}
+ function LastItem: TZAbstractObject;
+ function toJSONObject (names :JSONArray ): JSONObject ; overload ;
+ function toString: string; overload; override;
+ function toString2 (indentFactor: integer): string; overload;
+ function toString3 (indentFactor, indent: integer): string; overload;
+ function toList (): TList;
+ function appendJSONArray( value: JSONArray): Integer ; //2008-10-08
+ procedure Assign( Source: JSONArray);
+
+ function IndexOfObject(aobj: TObject): Integer; override; // by yangyxd
+ private
+ myArrayList: TList;
+ protected
+ function GetCount: Integer; override; // by yangyxd
+ function GetChild(Index: Integer): TZAbstractObject; override; // by yangyxd
+ procedure SetChild(Index: Integer; const Value: TZAbstractObject); override; // by yangyxd
+ end;
+
+
+ _Number = class (TZAbstractObject)
+ public
+ function doubleValue: double; virtual; abstract;
+ function intValue: integer; virtual; abstract;
+ function int64Value: Int64; virtual; abstract; // by yangyxd
+ end;
+
+ _Boolean = class (TZAbstractObject)
+ public
+ class function _TRUE (): _Boolean;
+ class function _FALSE (): _Boolean;
+ class function valueOf (b: boolean): _Boolean;
+ constructor create (b: boolean);
+ function boolValue: Boolean; //By creation_zy 2008-10-06
+ function toString (): string; override;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: boolean;
+ end;
+
+ _Double = class (_Number)
+ constructor create (const s: string); overload;
+ constructor create (s: _String); overload;
+ constructor create (d: double); overload;
+ function doubleValue: double; override;
+ function intValue: integer; override;
+ function int64Value: Int64; override;
+ function toString (): string ; override;
+ class function NaN: double;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: double;
+ end;
+
+ _Integer = class (_Number)
+ class function parseInt64 (const s: string): int64; overload;
+ class function parseInt64 (s: _String): int64; overload;
+ class function parseInt (const s: string; i: integer): integer; overload;
+ class function parseInt (s: _String): integer; overload;
+ class function toHexString (c: char): string;
+ constructor create (i: integer); overload;
+ constructor create (i: int64); overload;
+ constructor create (const s: string); overload;
+ function doubleValue: double; override;
+ function intValue: integer; override;
+ function int64Value: Int64; override;
+ function toString (): string; override;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: int64;
+ end;
+
+ _String = class (TZAbstractObject)
+ private
+ function GetAsString: String;
+ procedure SetAsString(const Value: String);
+ public
+ constructor create (const s: string);
+ function equalsIgnoreCase (const s: string): boolean;
+ function Equals(const Value: TZAbstractObject): Boolean; override;
+ function toString(): string; override;
+ function Clone :TZAbstractObject; override;
+ property AsString: String read GetAsString write SetAsString; //By creation_zy 2009-11-22
+ private
+ fvalue: string;
+ end;
+
+ _NULL = class (TZAbstractObject)
+ function Equals(const Value: TZAbstractObject): Boolean; override;
+ function toString(): string; override;
+ function Clone :TZAbstractObject; override; //By creation_zy 2009-12-11
+ end;
+
+{$IFDEF J_OBJECT}
+ _Object = class (TZAbstractObject)
+ function Equals(const Value: TZAbstractObject): Boolean; override;
+ function toString(): string; override;
+ function Clone :TZAbstractObject; override;
+ private
+ fvalue: TObject;
+ constructor Create(value: TObject);
+ procedure SetAsObject(const Value: TObject);
+ public
+ property AsObject: TObject read fvalue write SetAsObject;
+ end;
+{$ENDIF}
+
+ TJObjTransFlag=(jtfDbQouteStr, jtfQouteStr, jtfOtherAsStr);
+ TJObjTransFlags=set of TJObjTransFlag;
+
+function HexToInt(const S: String):Integer;
+function IsConstJSON(Z: TObject):Boolean;
+procedure SafeFreeJObj(Z: TObject);{$IF COMPILERVERSION>=18}inline;{$IFEND}
+function SpaceStr(ALen: Integer):String;
+function StrToAbstractJObj(const Str: String; Flags: TJObjTransFlags=[jtfDbQouteStr, jtfQouteStr]):TZAbstractObject;
+
+// by yangyxd 2013.11.06
+function JsonGetAttribute(const JSON, Name: string): string;
+function JsonGetAttributeAsInt(const JSON, Name: string): Integer;
+function JsonGetAttributeAsDouble(const JSON, Name: string): double;
+
+var
+ gcLista: TList;
+ CNULL: _NULL;
+ //Set this var to ture to force unicode char (eg: Chinese...) output in the form of \uXXXX
+ UnicodeOutput: Boolean=false;
+ SimpleJSON: Boolean=false; //2012-08-03
+
+implementation
+
+//{$D-}
+
+const
+ CROTINA_NAO_IMPLEMENTADA :string = 'Not imp';
+var
+ CONST_FALSE: _Boolean;
+ CONST_TRUE: _Boolean;
+
+//By creation_zy
+function IsSimpString(const Str:String):Boolean;
+var
+ i:Integer;
+begin
+ Result:=true;
+ for i:=1 to Length(Str) do
+ begin
+ Result:=Str[i] in ['0'..'9','a'..'z','A'..'Z','_'];
+ if not Result then exit;
+ end;
+end;
+
+//By creation_zy
+function SingleHZToJSONCode(const HZ:String):String;
+var
+ wstr:WideString;
+begin
+ if HZ='' then
+ begin
+ Result:='';
+ exit;
+ end;
+ wstr:=WideString(HZ);
+ Result:='\u'+IntToHex(PWord(@wstr[1])^,4);
+end;
+
+//By creation_zy 2009-11-21
+function IsConstJSON(Z: TObject):Boolean;
+begin
+ Result:=(Z=CNULL) or (Z=CONST_FALSE) or (Z=CONST_TRUE);
+end;
+
+procedure SafeFreeJObj(Z: TObject);
+begin
+ if not IsConstJSON(Z) then
+ Z.Free;
+end;
+
+function SpaceStr(ALen: Integer): string; {$IFDEF INLINE_OPT}inline;{$ENDIF}
+begin
+ if ALen > 0 then begin
+ SetLength(Result, ALen);
+ FillChar(Result[1], ALen, ' ');
+ end else Result := '';
+end;
+
+procedure newNotImplmentedFeature () ;
+begin
+ raise NotImplmentedFeature.create (CROTINA_NAO_IMPLEMENTADA);
+end;
+
+function getFormatSettings: TFormatSettings ;
+var
+ f: TFormatSettings;
+begin
+ {$IFDEF MSWINDOWS}
+ SysUtils.GetLocaleFormatSettings (Windows.GetThreadLocale,f);
+ {$ELSE}
+ newNotImplmentedFeature();
+ {$ENDIF}
+ Result:=f;
+ Result.DecimalSeparator:='.';
+ Result.ThousandSeparator:=',';
+end;
+
+
+function HexToInt(const S: String): Integer;
+const HexMap:array [Char] of SmallInt =
+ (
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1,
+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+ -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
+ );
+var
+ i, n, l: Integer;
+begin
+ Result:=0;
+ l:=Length(S);
+ if l=0 then exit;
+ if S[1]='$' then
+ n:=2
+ else if (l>=2) and (S[2] in ['x','X']) then
+ n:=3
+ else
+ n:=1;
+ for i:=n to l do
+ Result:=Result*16+HexMap[S[i]];
+end;
+
+function StrToAbstractJObj(const Str: String; Flags: TJObjTransFlags):TZAbstractObject;
+var
+ i:Integer;
+begin
+ if Str<>'' then
+ begin
+ case Str[1] of
+ '{':
+ begin
+ try
+ Result:=JSONObject.Create(Str);
+ except
+ Result:=nil;
+ end;
+ exit;
+ end;
+ '[':
+ begin
+ try
+ Result:=JSONArray.Create(Str);
+ except
+ Result:=nil;
+ end;
+ exit;
+ end;
+ '0'..'9','.','-':
+ begin
+ try
+ i:=StrToInt(Str);
+ Result:=_Integer.Create(i);
+ except
+ Result:=_Double.Create(StrToFloatDef(Str,0));
+ end;
+ exit;
+ end;
+ 'n':
+ begin
+ if Str='null' then
+ begin
+ Result:=CNull;
+ exit;
+ end;
+ end;
+ 't','T','F','f':
+ begin
+ if UpperCase(Str)='TRUE' then
+ begin
+ Result:=CONST_TRUE;
+ exit;
+ end
+ else if UpperCase(Str)='FALSE' then
+ begin
+ Result:=CONST_FALSE;
+ exit;
+ end;
+ end;
+ end;
+ end;
+ Result:=_String.create(Str);
+end;
+
+function mLeftPos(const SrcStr: AnsiString; SubChar: Char; sPos: Integer): Integer;
+var
+ i: Integer;
+begin
+ for i := sPos to Length(SrcStr) do
+ if SrcStr[i] = SubChar then begin
+ Result := i; Exit;
+ end;
+ Result := -1;
+end;
+
+function mRightPos(const SrcStr: AnsiString; SubChar: Char; sPos: Integer): Integer;
+var
+ i: Integer;
+begin
+ for i := sPos downto 1 do
+ if SrcStr[i] = SubChar then begin
+ Result := i; Exit;
+ end;
+ Result := -1;
+end;
+
+function mMidStr(const SrcStr: AnsiString; sPos, sCount: Integer): AnsiString;
+begin
+ Result := Copy(SrcStr, sPos, sCount);
+end;
+
+function JsonGetAttribute(const JSON, Name: string): string;
+var
+ i, j: Integer;
+begin
+ i := Pos('"'+Name+'":"', JSON);
+ if i > 0 then begin
+ i := i + Length(Name) + 4;
+ j := mLeftPos(JSON, '"', i);
+ Result := Copy(JSON, i, j - i);
+ end;
+end;
+
+function JsonGetAttributeAsInt(const JSON, Name: string): Integer;
+var
+ i, j: Integer;
+begin
+ Result := 0;
+ i := Pos('"'+Name+'":', JSON);
+ if i > 0 then begin
+ i := i + Length(Name) + 3;
+ j := mLeftPos(JSON, ',', i);
+ if (j < 0) then
+ j := mLeftPos(JSON, '}', i);
+ if (j > 0) then begin
+ if JSON[i] = '"' then i := i + 1;
+ if JSON[j-1] = '"' then j := j - 1;
+ Result := StrToIntDef(Copy(JSON, i, j - i), 0);
+ end;
+ end;
+end;
+
+function JsonGetAttributeAsDouble(const JSON, Name: string): double;
+var
+ i, j: Integer;
+begin
+ Result := 0;
+ i := Pos('"'+Name+'":', JSON);
+ if i > 0 then begin
+ i := i + Length(Name) + 3;
+ j := mLeftPos(JSON, ',', i);
+ if (j < 0) then
+ j := mLeftPos(JSON, '}', i);
+ if (j > 0) then begin
+ if JSON[i] = '"' then i := i + 1;
+ if JSON[j-1] = '"' then j := j - 1;
+ Result := StrToFloatDef(Copy(JSON, i, j - i), 0);
+ end;
+ end;
+end;
+
+{ JSONTokener }
+
+(**
+ * Construct a JSONTokener from a string.
+ *
+ * @param s A source string.
+ *)
+constructor JSONTokener.create(const s: string);
+begin
+ myIndex:=1;
+ mySource:=s;
+ Len1:=Length(mySource)+1;
+end;
+
+(**
+ * Back up one character. This provides a sort of lookahead capability,
+ * so that you can test for a digit or letter before attempting to parse
+ * the next number or identifier.
+*)
+procedure JSONTokener.back;
+begin
+ if myIndex>1 then Dec(myIndex);
+end;
+
+(**
+ * Get the hex value of a character (base16).
+ * @param c A character between '0' and '9' or between 'A' and 'F' or
+ * between 'a' and 'f'.
+ * @return An int between 0 and 15, or -1 if c was not a hex digit.
+ *)
+class function JSONTokener.dehexchar(c: char): integer;
+begin
+ if ((c >= '0') and (c <= '9')) then begin
+ Result:= (ord(c) - ord('0'));
+ exit;
+ end;
+ if ((c >= 'A') and (c <= 'F')) then begin
+ Result:= (ord(c) + 10 - ord('A'));
+ exit;
+ end;
+ if ((c >= 'a') and (c <= 'f')) then begin
+ Result:=ord(c) + 10 - ord('a');
+ exit;
+ end;
+ Result:=-1;
+end;
+
+
+(**
+ * Determine if the source string still contains characters that next()
+ * can consume.
+ * @return true if not yet at the end of the source.
+*)
+function JSONTokener.more: boolean;
+begin
+ Result:=myIndex<=Len1{System.length(mySource)+1};
+end;
+
+function JSONTokener.next: char;
+begin
+ if {$IFDEF BACK_OPT}myIndex<=Len1{$ELSE}more(){$ENDIF} then
+ begin
+ Result:=mySource[myIndex];
+ Inc(myIndex);
+ end
+ else
+ Result:=chr(0);
+end;
+
+
+ (**
+ * Consume the next character, and check that it matches a specified
+ * character.
+ * @param c The character to match.
+ * @return The character.
+ * @throws ParseException if the character does not match.
+ *)
+function JSONTokener.next(c: char): char;
+begin
+ Result:=next();
+ if (Result <> c) then
+ raise syntaxError('Expected ' + c + ' and instead saw ' + Result + '.');
+end;
+
+
+(**
+ * Get the next n characters.
+ *
+ * @param n The number of characters to take.
+ * @return A string of n characters.
+ * @exception ParseException
+ * Substring bounds error if there are not
+ * n characters remaining in the source string.
+ *)
+function JSONTokener.next(n: integer): string;
+var
+ i,j: integer;
+begin
+ i:=self.myIndex;
+ j:=i + n;
+ if (j > System.length(self.mySource)) then begin
+ raise syntaxError('Substring bounds error');
+ end;
+ self.myIndex:=self.myIndex + n;
+ Result:=copy (self.mySource,i,n); //substring(i, j)
+end;
+
+ (**
+ * Get the next char in the string, skipping whitespace
+ * and comments (slashslash, slashstar, and hash).
+ * @throws ParseException
+ * @return A character, or 0 if there are no more characters.
+ *)
+function JSONTokener.nextClean: char;
+var
+ c: char;
+begin
+ while true do
+ begin
+ {$IFDEF NEXT_OPT2}
+ if myIndex<=Len1 then
+ begin
+ Result:=mySource[myIndex];
+ Inc(myIndex);
+ end
+ else begin
+ Result:=#0;
+ exit;
+ end;
+ {$ELSE}
+ Result:=next();
+ {$ENDIF}
+ if (Result = '/') then
+ begin
+ case (next()) of
+ '/': begin
+ repeat
+ c:=next();
+ until (not ((c <> #10) and (c <> #13) and (c <> #0)));
+ end ;
+ '*':
+ begin
+ while (true) do
+ begin
+ c:=next();
+ if (c = #0) then
+ begin
+ raise syntaxError('Unclosed comment.');
+ end;
+ if (c = '*') then
+ begin
+ if (next() = '/') then break;
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ end;
+ end;
+ end
+ else begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:='/';
+ exit;
+ end;
+ end;
+ end
+ else if (Result = '#') then
+ begin
+ repeat
+ c:=next();
+ until (not ((c <> #10) and (c <> #13) and (c <> #0)));
+ end
+ else if ((Result = #0) or (Result > ' ')) then
+ exit;
+ end; //while
+end;
+
+
+(**
+ * Return the characters up to the next close quote character.
+ * Backslash processing is done. The formal JSON format does not
+ * allow strings in single quotes, but an implementation is allowed to
+ * accept them.
+ * @param quote The quoting character, either
+ * " (double quote) or
+ * ' (single quote).
+ * @return A String.
+ * @exception ParseException Unterminated string.
+ *)
+function JSONTokener.nextString (quote: char): string;
+var
+ c: char;
+ sb: string;
+ WCh:WideChar;
+begin
+ sb:='';
+ while (true) do
+ begin
+ c:=next();
+ case (c) of
+ #0, #10, #13:
+ begin
+ //Ignore #10 and #13 inside a string. By creation_zy 2009-11-22
+ if c=#0 then
+ raise syntaxError('Unterminated string')
+ else
+ continue;
+ end;
+ '\':
+ begin
+ c:=next();
+ case (c) of
+ {'b': // ?o backspace = #8
+ sb.append('\b');
+ break;}
+ 'b': //By creation_zy 2009-08-20
+ sb:=sb + #8;
+ 't':
+ sb:=sb + #9;
+ 'n':
+ sb:=sb + #10;
+ 'f':
+ sb:=sb + #12;
+ 'r':
+ sb:=sb + #13;
+ {case 'u':
+ sb.append((char)Integer.parseInt(next(4), 16));
+ break;
+ case 'x': \cx The control character corresponding to x
+ sb.append((char) Integer.parseInt(next(2), 16));
+ break;}
+ 'u': //By creation_zy 2009-08-20
+ begin
+ PWord(@WCh)^:=Word(HexToInt(next(4)));
+ sb:=sb+WCh;
+ end;
+ else
+ sb:=sb + c
+ end;
+ end
+ else begin
+ if (c = quote) then
+ begin
+ Result:=sb;
+ exit;
+ end;
+ sb:=sb + c
+ end;
+ end;
+ end;
+end;
+
+(**
+ * Get the text up but not including the specified character or the
+ * end of line, whichever comes first.
+ * @param d A delimiter character.
+ * @return A string.
+ *)
+function JSONTokener.nextTo(d: char): string;
+var
+ sb: string;
+ c: char;
+begin
+ //c:=#0;
+ sb:='';
+ while (true) do
+ begin
+ c:=next();
+ if ((c = d) or (c = #0) or (c = #10) or (c = #13)) then
+ begin
+ if (c <> #0) then
+ begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ end;
+ Result:=trim (sb);
+ exit;
+ end;
+ sb:=sb + c;
+ end;
+end;
+
+(**
+ * Get the text up but not including one of the specified delimeter
+ * characters or the end of line, whichever comes first.
+ * @param delimiters A set of delimiter characters.
+ * @return A string, trimmed.
+*)
+function JSONTokener.nextTo(const delimiters: string): char;
+var
+ c: char;
+ sb: string;
+begin
+ //c:=#0;
+ Result:=#0; //By creation_zy
+ sb:='';
+ while (true) do
+ begin
+ c:=next();
+ if ((pos (c,delimiters) > 0) or (c = #0) or
+ (c = #10) or (c = #13)) then
+ begin
+ if (c <> #0) then
+ begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ end;
+ sb:=trim(sb);
+ if (System.length(sb) > 0) then
+ Result:=sb[1];
+ exit;
+ end;
+ sb:=sb + c;
+ end;
+end;
+
+(**
+ * Get the next value. The value can be a Boolean, Double, Integer,
+ * JSONArray, JSONObject, or String, or the JSONObject.NULL object.
+ * @exception ParseException The source does not conform to JSON syntax.
+ *
+ * @return An object.
+*)
+function JSONTokener.nextValue(parent: JSONBase): TZAbstractObject; // by yangyxd parent
+var
+ c, b: char;
+ s , sb: string;
+ n:Integer;
+begin
+ c:=nextClean();
+
+ case (c) of
+ '"', #39: begin
+ Result:=_String.create (nextString(c));
+ exit;
+ end;
+ '{': begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:=JSONObject.create(self);
+ JSONObject(Result).Parent := parent;
+ exit;
+ end;
+ '[': begin
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:=JSONArray.create(self);
+ JSONArray(Result).Parent := parent;
+ exit;
+ end;
+ end;
+
+ (*
+ * Handle unquoted text. This could be the values true, false, or
+ * null, or it can be a number. An implementation (such as this one)
+ * is allowed to also accept non-standard forms.
+ *
+ * Accumulate characters until we reach the end of the text or a
+ * formatting character.
+ *)
+
+ sb:='';
+ b:=c;
+ while ((ord(c) >= ord(' ')) and (pos (c,',:]}/\\\"[{;=#') = 0)) do begin
+ sb:=sb + c;
+ c:=next();
+ end;
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+
+ (*
+ * If it is true, false, or null, return the proper value.
+ *)
+
+ s:=trim (sb);
+ n:=System.Length(s);
+ if n=0 then
+ raise syntaxError('Missing value.');
+ if n in [4,5] then //2009-09-14 Length limit before AnsiLowerCase. By creation_zy
+ begin
+ sb:=AnsiLowerCase(s);
+ if (sb = 'true') then
+ begin
+ Result:= _Boolean._TRUE;
+ exit;
+ end;
+
+ if (sb = 'false') then
+ begin
+ Result:=_Boolean._FALSE;
+ exit;
+ end;
+ if (sb = 'null') then
+ begin
+ Result:=JSONObject.NULL;
+ exit;
+ end;
+ end;
+
+ (*
+ * If it might be a number, try converting it. We support the 0- and 0x-
+ * conventions. If a number cannot be produced, then the value will just
+ * be a string. Note that the 0-, 0x-, plus, and implied string
+ * conventions are non-standard. A JSON parser is free to accept
+ * non-JSON forms as long as it accepts all correct JSON forms.
+ *)
+
+ if ( ((b >= '0') and (b <= '9')) or (b = '.')
+ or (b = '-') or (b = '+')) then
+ begin
+ if (b = '0') then begin
+ if ( (System.length(s) > 2) and
+ ((s[2] = 'x') or (s[2] = 'X') ) ) then
+ begin
+ try
+ Result:=_Integer.create(_Integer.parseInt(copy(s,3,System.length(s)),16));
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+ end else begin
+ try
+ if (System.length(s) >= 2) and (s[2]='.') then //2009-09-14 By creation_zy
+ Result:=_Double.create(s)
+ else
+ Result:=_Integer.create(_Integer.parseInt(s,8));
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+ end;
+ end;
+ if Pos('.',s)=0 then //2011-10-02 Bug fixed. By creation_zy
+ try
+ Result:=_Integer.create(s);
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+
+ try
+ Result:=_Double.create(s);
+ exit;
+ Except
+ on e:Exception do begin
+ ///* Ignore the error */
+ end;
+ end;
+ end;
+ Result:=_String.create(s);
+end;
+
+(**
+ * Skip characters until the next character is the requested character.
+ * If the requested character is not found, no characters are skipped.
+ * @param to A character to skip to.
+ * @return The requested character, or zero if the requested character
+ * is not found.
+ *)
+function JSONTokener.skipTo(_to: char): char;
+var
+ c: char;
+ index: integer;
+begin
+ index:=self.myIndex;
+ repeat
+ c:=next();
+ if (c = #0) then
+ begin
+ self.myIndex:=index;
+ Result:=c;
+ exit;
+ end;
+ until c=_to;
+ {$IFDEF BACK_OPT}if myIndex>1 then Dec(myIndex);{$ELSE}back();{$ENDIF}
+ Result:=c;
+ exit;
+end;
+
+(**
+ * Skip characters until past the requested string.
+ * If it is not found, we are left at the end of the source.
+ * @param to A string to skip past.
+ *)
+procedure JSONTokener.skipPast(const _to: string);
+begin
+ self.myIndex:=pos (_to, copy(mySource, self.myIndex, System.length(mySource)));
+ if (self.myIndex < 0) then begin
+ self.myIndex:=System.length(self.mySource)+1;
+ end else begin
+ self.myIndex:=self.myIndex + System.length(_to);
+ end;
+end;
+
+
+
+(**
+ * Make a ParseException to signal a syntax error.
+ *
+ * @param message The error message.
+ * @return A ParseException object, suitable for throwing
+ *)
+function JSONTokener.syntaxError(const _message: string): ParseException;
+begin
+ Result:=ParseException.create (_message + toString()+' postion: ' //' prximo a: '
+ + copy (toString(),self.myIndex,10), self.myIndex);
+end;
+
+(**
+ * Make a printable string of this JSONTokener.
+ *
+ * @return " at character [this.myIndex] of [this.mySource]"
+ *)
+
+
+function JSONTokener.toString: string;
+begin
+ Result:=' at character ' + intToStr(myIndex) + ' of ' + mySource;
+end;
+
+
+(**
+ * Convert %hh sequences to single characters, and
+ * convert plus to space.
+ * @param s A string that may contain
+ * + (plus) and
+ * %hh sequences.
+ * @return The unescaped string.
+ *)
+function JSONTokener.unescape(const s: string): string;
+var
+ len, i,d,e: integer;
+ b: string;
+ c: char;
+begin
+ len:=System.length(s);
+ b:='';
+ i:=1;
+ while ( i <= len ) do begin
+ c:=s[i];
+ if (c = '+') then begin
+ c:=' ';
+ end
+ else if ((c = '%') and ((i + 2) <= len)) then
+ begin
+ d:=dehexchar(s[i + 1]);
+ e:=dehexchar(s[i + 2]);
+ if ((d >= 0) and (e >= 0)) then
+ begin
+ c:=chr(d * 16 + e);
+ i:=i + 2;
+ end;
+ end;
+ b:=b + c;
+ i:=i + 1;
+ end;
+ Result:=b ;
+end;
+
+{ JSONObject }
+
+(**
+* Construct an empty JSONObject.
+*)
+constructor JSONObject.create;
+begin
+ myHashMap:=TStringList.create;
+ inherited Create;
+end;
+
+
+(**
+ * Construct a JSONObject from a subset of another JSONObject.
+ * An array of strings is used to identify the keys that should be copied.
+ * Missing keys are ignored.
+ * @param jo A JSONObject.
+ * @param sa An array of strings.
+ *)
+constructor JSONObject.create(jo: JSONObject; sa: array of string);
+var
+ i: integer;
+begin
+ create();
+ for i:=low(sa) to high(sa) do
+ putOpt(sa[i], jo.opt(sa[i]).Clone);
+end;
+
+(**
+ * Construct a JSONObject from a JSONTokener.
+ * @param x A JSONTokener object containing the source string.
+ * @throws ParseException if there is a syntax error in the source string.
+ *)
+constructor JSONObject.create(x: JSONTokener);
+begin
+ create ;
+ UpdateByTokener(x);
+end;
+
+(**
+ * Construct a JSONObject from a Map.
+ * @param map A map object that can be used to initialize the contents of
+ * the JSONObject.
+ *)
+constructor JSONObject.create(map: TStringList);
+var
+ i: integer;
+begin
+ myHashMap:=TStringlist.create;
+ for i:=0 to map.Count -1 do
+ myHashMap.AddObject(map[i],map.Objects[i]);
+end;
+
+(**
+ * Construct a JSONObject from a string.
+ * This is the most commonly used JSONObject constructor.
+ * @param string A string beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ * @exception ParseException The string must be properly formatted.
+ *)
+constructor JSONObject.create(const s: string);
+var
+ token: JSOnTokener;
+begin
+ if s='' then //Add by creation_zy 2008-10-21
+ begin
+ create();
+ exit;
+ end;
+ token:=JSONTokener.create(s);
+ try
+ create(token);
+ finally
+ token.free;
+ end;
+end;
+
+
+constructor JSONObject.CreateInArray(Ay: JSONArray);
+begin
+ create;
+ if Ay<>nil then
+ Ay.put(Self);
+end;
+
+(**
+ * Accumulate values under a key. It is similar to the put method except
+ * that if there is already an object stored under the key then a
+ * JSONArray is stored under the key to hold all of the accumulated values.
+ * If there is already a JSONArray, then the new value is appended to it.
+ * In contrast, the put method replaces the previous value.
+ * @param key A key string.
+ * @param value An object to be accumulated under the key.
+ * @return this.
+ * @throws NullPointerException if the key is null
+ *)
+function JSONObject.accumulate(const key: string; value: TZAbstractObject): JSONObject;
+var
+ a: JSONArray;
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o = nil) then
+ put(key, value)
+ else if (o is JSONArray) then
+ begin
+ a:=JSONArray(o);
+ a.put(value);
+ end
+ else begin
+ a:=JSONArray.create;
+ a.put(o.Clone);
+ a.put(value);
+ put(key, a);
+ end;
+ Result:=self;
+end;
+
+
+(**
+ * Get the value object associated with a key.
+ *
+ * @param key A key string.
+ * @return The object associated with the key.
+ * @exception NoSuchElementException if the key is not found.
+ *)
+function JSONObject.get(const key: string): TZAbstractObject;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o = nil) then
+ raise NoSuchElementException.create('JSONObject['+quote(key)+'] not found.');
+ Result:=o;
+end;
+
+
+(**
+ * Get the boolean value associated with a key.
+ *
+ * @param key A key string.
+ * @return The truth.
+ * @exception NoSuchElementException if the key is not found.
+ * @exception ClassCastException
+ * if the value is not a Boolean or the String "true" or "false".
+ *)
+function JSONObject.getBoolean(const key: string): boolean;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o.equals(_Boolean._FALSE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('false'))) then begin
+ Result:=false;
+ exit;
+ end
+ else if (o.equals(_Boolean._TRUE) or
+ ((o is _String) and
+ (_String(o)).equalsIgnoreCase('true'))) then begin
+ Result:=true;
+ exit;
+ end;
+ raise ClassCastException.create('JSONObject[' +
+ quote(key) + '] is not a Boolean.');
+end;
+
+function JSONObject.getDouble(const key: string): double;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is _Number) then
+ begin
+ Result:=_Number (o).doubleValue();
+ exit;
+ end ;
+ if (o is _String) then
+ begin
+ Result:=StrToFloat (_String(o).toString(), getFormatSettings());
+ exit;
+ end;
+ raise NumberFormatException.create('JSONObject['+quote(key)+'] is not a number.');
+end;
+
+
+(**
+ * Get the int value associated with a key.
+ *
+ * @param key A key string.
+ * @return The integer value.
+ * @exception NoSuchElementException if the key is not found
+ * @exception NumberFormatException
+ * if the value cannot be converted to a number.
+ *)
+function JSONObject.getInt(const key: string): integer;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is _Number) then
+ Result:= _Number(o).intValue()
+ else
+ Result:= Round(getDouble(key));
+end;
+
+
+function JSONObject.GetInt64(const key: string): Int64;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is _Number) then
+ Result:= _Number(o).int64Value()
+ else
+ Result:= Round(getDouble(key));
+end;
+
+(**
+ * Get the JSONArray value associated with a key.
+ *
+ * @param key A key string.
+ * @return A JSONArray which is the value.
+ * @exception NoSuchElementException if the key is not found or
+ * if the value is not a JSONArray.
+ *)
+function JSONObject.getJSONArray(const key: string): JSONArray;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is JSONArray) then
+ Result:=JSONArray(o)
+ else
+ raise NoSuchElementException.create('JSONObject[' +
+ quote(key) + '] is not a JSONArray.');
+end;
+
+
+(**
+ * Get the JSONObject value associated with a key.
+ *
+ * @param key A key string.
+ * @return A JSONObject which is the value.
+ * @exception NoSuchElementException if the key is not found or
+ * if the value is not a JSONObject.
+ *)
+function JSONObject.getJSONObject(const key: string): JSONObject;
+var
+ o: TZAbstractObject;
+begin
+ o:=get(key);
+ if (o is JSONObject) then
+ Result:=JSONObject(o)
+ else
+ raise NoSuchElementException.create('JSONObject[' +
+ quote(key) + '] is not a JSONObject.');
+end;
+
+
+(**
+ * Get the string associated with a key.
+ *
+ * @param key A key string.
+ * @return A string which is the value.
+ * @exception NoSuchElementException if the key is not found.
+*)
+function JSONObject.getString(const key: string): string;
+begin
+ Result:=get(key).toString();
+end;
+
+
+(**
+ * Determine if the JSONObject contains a specific key.
+ * @param key A key string.
+ * @return true if the key exists in the JSONObject.
+ *)
+function JSONObject.has(const key: string): boolean;
+begin
+ Result:=myHashMap.IndexOf(key)>=0;
+end;
+
+function JSONObject.IndexOfObject(aobj: TObject): Integer;
+var
+ i: Integer;
+begin
+ for i := 0 to myHashMap.Count - 1 do
+ if myHashMap.Objects[i] = aobj then begin
+ Result := I;
+ Exit;
+ end;
+ Result := -1;
+end;
+
+(**
+ * Determine if the value associated with the key is null or if there is
+ * no value.
+ * @param key A key string.
+ * @return true if there is no value associated with the key or if
+ * the value is the JSONObject.NULL object.
+ *)
+function JSONObject.isNull(const key: string): boolean;
+begin
+ Result:=NULL.equals(opt(key));
+end;
+
+function JSONObject.keys: TStringList;
+var
+ i: integer;
+begin
+ Result:=TStringList.Create;
+ for i:=0 to myHashMap.Count -1 do
+ Result.add (myHashMap[i]);
+end;
+
+function JSONObject.length: integer;
+begin
+ Result:=myHashMap.Count;
+end;
+
+
+(**
+ * Produce a JSONArray containing the names of the elements of this
+ * JSONObject.
+ * @return A JSONArray containing the key strings, or null if the JSONObject
+ * is empty.
+ *)
+function JSONObject.names: JSONArray;
+var
+ i,c: integer;
+ k: TStringList;
+begin
+ Result:=nil;
+ k:=keys;
+ try
+ c:=k.Count;
+ if c>0 then //2013-05-04 Fix memory leak bug found by K.o.s
+ begin
+ Result:=JSONArray.create;
+ for i:=0 to c-1 do
+ Result.put(_String.create(k[i]));
+ end;
+ finally
+ k.free;
+ end;
+end;
+
+function JSONObject.NextSibling: JSONObject;
+var
+ i: Integer;
+begin
+ if not Assigned(Parent) then
+ Result := nil
+ else begin
+ i := Parent.IndexOfObject(Self) + 1;
+ if (i > 0) and (i < Parent.Count) then begin
+ if Parent.Child[i] is JSONObject then
+ Result := JSONObject(Parent.Child[i])
+ else Result := nil;
+ end else
+ Result := nil;
+ end;
+end;
+
+class function JSONObject.numberToString(n: _Number): string;
+begin
+ if (n = nil) then
+ Result:=''
+ else if (n is _Integer) then
+ Result:=IntToStr(n.intValue)
+ else
+ Result:=FloatToStr(n.doubleValue, getFormatSettings());
+end;
+
+
+(**
+ * Get an optional value associated with a key.
+ * @param key A key string.
+ * @return An object which is the value, or null if there is no value.
+ * @exception NullPointerException The key must not be null.
+ *)
+function JSONObject.opt(const key: string): TZAbstractObject;
+var
+ i:Integer;
+begin
+ i:=myHashMap.IndexOf(key);
+ if i<0 then
+ Result:=nil
+ else
+ Result:=TZAbstractObject(myHashMap.Objects[i]);
+end;
+
+function JSONObject.Opt2(key, key2: string): TZAbstractObject;
+var
+ i:Integer;
+begin
+ i:=myHashMap.IndexOf(key);
+ if i<0 then
+ i:=myHashMap.IndexOf(key2);
+ if i<0 then
+ Result:=nil
+ else
+ Result:=TZAbstractObject(myHashMap.Objects[i]);
+end;
+
+(**
+ * Get an optional boolean associated with a key.
+ * It returns false if there is no such key, or if the value is not
+ * Boolean.TRUE or the String "true".
+ *
+ * @param key A key string.
+ * @return The truth.
+ *)
+function JSONObject.optBoolean(const key: string): boolean;
+begin
+ Result:=optBoolean(key, false);
+end;
+
+
+(**
+ * Get an optional boolean associated with a key.
+ * It returns the defaultValue if there is no such key, or if it is not
+ * a Boolean or the String "true" or "false" (case insensitive).
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return The truth.
+ *)
+function JSONObject.optBoolean(const key: string;
+ defaultValue: boolean): boolean;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> nil) then
+ begin
+ if o.ClassType=_Boolean then //2009-03-06 By creation_zy
+ begin
+ Result:=_Boolean(o).fvalue;
+ exit;
+ end
+ else if //o.equals(_Boolean._FALSE) or
+ ((o is _String) and
+ (_String(o).equalsIgnoreCase('false'))) then begin
+ Result:=false;
+ exit;
+ end
+ else if //o.equals(_Boolean._TRUE) or
+ ((o is _String) and
+ (_String(o).equalsIgnoreCase('true'))) then begin
+ Result:=true;
+ exit;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+
+(**
+ * Get an optional double associated with a key,
+ * or NaN if there is no such key or if its value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A string which is the key.
+ * @return An object which is the value.
+ *)
+function JSONObject.optDouble(const key: string): double;
+begin
+ Result:=optDouble(key, _Double.NaN);
+end;
+
+
+(**
+ * Get an optional double associated with a key, or the
+ * defaultValue if there is no such key or if its value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return An object which is the value.
+ *)
+function JSONObject.optDouble(const key: string; defaultValue: double): double;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> nil) then
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).doubleValue();
+ exit;
+ end;
+ try
+ Result:=_Double.create(_String(o)).doubleValue();
+ exit;
+ except
+ on e:Exception do
+ begin
+ Result:=defaultValue;
+ exit;
+ end;
+ end;
+ end;
+ Result:=defaultValue;
+end;
+
+(**
+ * Get an optional int value associated with a key,
+ * or zero if there is no such key or if the value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A key string.
+ * @return An object which is the value.
+ *)
+function JSONObject.optInt(const key: string): integer;
+begin
+ Result:=optInt(key, 0);
+end;
+
+
+(**
+ * Get an optional int value associated with a key,
+ * or the default if there is no such key or if the value is not a number.
+ * If the value is a string, an attempt will be made to evaluate it as
+ * a number.
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return An object which is the value.
+ *)
+function JSONObject.optInt(const key: string; defaultValue: integer): integer;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> null) and ( o <> nil ) then //By creation_zy. Add compare to nil
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).intValue();
+ exit;
+ end;
+ try
+ Result:=_Integer.parseInt(_String(o));
+ except
+ on e:Exception do
+ begin
+ Result:=defaultValue;
+ end;
+ end;
+ end
+ else //By creation_zy
+ Result:=defaultValue;
+end;
+
+function JSONObject.OptInt2(key, key2: String; DefaultValue: Integer): Integer;
+var
+ o:TZAbstractObject;
+begin
+ o:=Opt2(key,key2);
+ if o<>nil then
+ Result:=TZAbstractObject.getInt(o,DefaultValue)
+ else
+ Result:=DefaultValue;
+end;
+
+function JSONObject.OptInt64(const key: string): int64;
+begin
+ Result:=optInt64(key, 0);
+end;
+
+function JSONObject.OptInt64(const key: string; defaultValue: int64): int64;
+var
+ o: TZAbstractObject;
+begin
+ o:=opt(key);
+ if (o <> null) and ( o <> nil ) then //By creation_zy. Add compare to nil
+ begin
+ if (o is _Number) then
+ begin
+ Result:=(_Number(o)).int64Value();
+ exit;
+ end;
+ try
+ Result:=_Integer.parseInt64(_String(o));
+ except
+ on e:Exception do
+ begin
+ Result:=defaultValue;
+ end;
+ end;
+ end
+ else //By creation_zy
+ Result:=defaultValue;
+end;
+
+(**
+ * Get an optional JSONArray associated with a key.
+ * It returns null if there is no such key, or if its value is not a
+ * JSONArray.
+ *
+ * @param key A key string.
+ * @return A JSONArray which is the value.
+ *)
+function JSONObject.optJSONArray(const key: string): JSONArray;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is JSONArray) then
+ Result:=JSONArray(o)
+ else
+ Result:=nil;
+end;
+
+
+(**
+ * Get an optional JSONObject associated with a key.
+ * It returns null if there is no such key, or if its value is not a
+ * JSONObject.
+ *
+ * @param key A key string.
+ * @return A JSONObject which is the value.
+ *)
+function JSONObject.optJSONObject(const key: string): JSONObject;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is JSONObject) then
+ Result:=JSONObject(o)
+ else
+ Result:=nil;
+end;
+
+{$IFDEF J_OBJECT}
+function JSONObject.OptObject(const key: string;
+ defaultValue: TObject): TObject;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is _Object) then
+ Result:=_Object(o).AsObject
+ else
+ Result:=defaultValue;
+end;
+
+function JSONObject.OptObject(const key: string): TObject;
+var
+ o: TZAbstractObject ;
+begin
+ o:=opt(key);
+ if (o is _Object) then
+ Result:=_Object(o).AsObject
+ else
+ Result:=nil;
+end;
+{$ENDIF}
+
+(**
+ * Get an optional string associated with a key.
+ * It returns an empty string if there is no such key. If the value is not
+ * a string and is not null, then it is coverted to a string.
+ *
+ * @param key A key string.
+ * @return A string which is the value.
+ *)
+function JSONObject.optString(const key: string): string;
+var
+ o: TZAbstractObject ;
+ i:Integer;
+begin
+ i:=myHashMap.IndexOf(key);
+ if i<0 then
+ Result:=''
+ else begin
+ o:=TZAbstractObject(myHashMap.Objects[i]);
+ if (o <> nil) then
+ Result:=o.toString()
+ else
+ Result:='';
+ end;
+end;
+
+(**
+ * Get an optional string associated with a key.
+ * It returns the defaultValue if there is no such key.
+ *
+ * @param key A key string.
+ * @param defaultValue The default.
+ * @return A string which is the value.
+ *)
+function JSONObject.optString(const key, defaultValue: string): string;
+var
+ o: TZAbstractObject ;
+begin
+ o:=Opt(key);
+ if (o <> nil) then
+ Result:=o.toString()
+ else
+ Result:=defaultValue;
+end;
+
+function JSONObject.OptString2(key, key2: String; DefaultValue: String): String;
+var
+ o:TZAbstractObject;
+begin
+ o:=Opt2(key,key2);
+ if o<>nil then
+ Result:=o.toString()
+ else
+ Result:=DefaultValue;
+end;
+
+(**
+ * Put a key/boolean pair in the JSONObject.
+ *
+ * @param key A key string.
+ * @param value A boolean which is the value.
+ * @return this.
+ *)
+function JSONObject.put(const key: string; value: boolean): JSONObject;
+begin
+ put(key, _Boolean.valueOf(value));
+ Result:=self;
+end;
+
+(**
+ * Put a key/double pair in the JSONObject.
+ *
+ * @param key A key string.
+ * @param value A double which is the value.
+ * @return this.
+ *)
+function JSONObject.put(const key: string; value: double): JSONObject;
+begin
+ put(key, _Double.create(value));
+ Result:=self;
+end;
+
+
+(**
+ * Put a key/int pair in the JSONObject.
+ *
+ * @param key A key string.
+ * @param value An int which is the value.
+ * @return this.
+ *)
+function JSONObject.put(const key: string; value: integer): JSONObject;
+begin
+ put(key, _Integer.create(value));
+ Result:=self;
+end;
+
+
+(**
+ * Put a key/value pair in the JSONObject. If the value is null,
+ * then the key will be removed from the JSONObject if it is present.
+ * @param key A key string.
+ * @param value An object which is the value. It should be of one of these
+ * types: Boolean, Double, Integer, JSONArray, JSONObject, String, or the
+ * JSONObject.NULL object.
+ * @return this.
+ * @exception NullPointerException The key must be non-null.
+ *)
+function JSONObject.put(const key: string; value: TZAbstractObject): JSONObject;
+var
+ temp: TObject;
+ i: integer;
+begin
+ if (key = '') then
+ begin
+ raise NullPointerException.create('Null key.');
+ end ;
+ if (value <> nil) then {$D+}
+ begin
+ i:=myHashMap.IndexOf(key);
+ if ( i >= 0) then
+ begin
+ temp:=myHashMap.Objects [i];
+ myHashMap.Objects[i]:=value;
+ if (temp<>CNULL) and (temp<>CONST_FALSE) and (temp<>CONST_TRUE) then //Prevent to free const obj. By craetion_zy 2009-11-21
+ temp.free;
+ end
+ else
+ myHashMap.AddObject(key, value);
+ end
+ else begin
+ temp:=remove(key);
+ if (temp<>nil) and (temp<>CNULL) and (temp<>CONST_FALSE) and (temp<>CONST_TRUE) then //Prevent to free const obj. By craetion_zy 2009-11-21
+ temp.free;
+ end;
+ Result:=self;
+end;
+
+function JSONObject.put(const key, value: string): JSONObject;
+begin
+ put(key, _String.create(value));
+ Result:=self;
+end;
+
+{$IFDEF J_OBJECT}
+function JSONObject.Put(const key: string; value: TObject): JSONObject;
+begin
+ put(key, _Object.create(value));
+ Result:=self;
+end;
+function JSONObject.Put(const key: string; value: int64): JSONObject;
+begin
+ put(key, _Integer.create(value));
+ Result:=self;
+end;
+
+{$ENDIF}
+
+(**
+ * Put a key/value pair in the JSONObject, but only if the
+ * value is non-null.
+ * @param key A key string.
+ * @param value An object which is the value. It should be of one of these
+ * types: Boolean, Double, Integer, JSONArray, JSONObject, String, or the
+ * JSONObject.NULL object.
+ * @return this.
+ * @exception NullPointerException The key must be non-null.
+ *)
+function JSONObject.putOpt(const key: string; value: TZAbstractObject): JSONObject;
+begin
+ if (value <> nil) then
+ put(key, value);
+ Result:=self;
+end;
+
+
+(**
+ * Produce a string in double quotes with backslash sequences in all the
+ * right places.
+ * @param string A String
+ * @return A String correctly formatted for insertion in a JSON message.
+ *)
+class function JSONObject.quote(const s: string): string;
+var
+ b,c: char;
+ i, len: integer;
+ sb, t: string;
+begin
+ if ((s = '') or (System.Length(s) = 0)) then
+ begin
+ Result:= '""';
+ exit;
+ end;
+
+ //b:=#0;
+ c:=#0;
+ len:=System.length(s);
+ //SetLength (s, len+4);
+ t:='';
+
+ sb:=sb +'"';
+ i:=1;
+ while i<=len do
+ begin
+ b:=c;
+ c:=s[i];
+ case (c) of
+ '\', '"':
+ begin
+ sb:=sb + '\';
+ sb:=sb + c;
+ end;
+ '/':
+ begin
+ if (b = '<') then
+ begin
+ sb:=sb + '\';
+ end;
+ sb:=sb + c;
+ end;
+ {#8, #9, #10, #12, #13:
+ begin
+ sb:=sb + c;
+ end;}
+ //Output special character smaller than space. By creation_zy 2009-11-22
+ #0: sb:=sb + '\u0000';
+ #1..#7: sb:=sb + '\u000'+Char(Byte('0')+Byte(c));
+ #8: sb:=sb + '\b';
+ #9: sb:=sb + '\t';
+ #10: sb:=sb + '\n';
+ #12: sb:=sb + '\f';
+ #13: sb:=sb + '\r';
+ else
+ begin
+ if (c < ' ') then
+ begin
+ t:='000' + _Integer.toHexString(c);
+ sb:=sb + '\u' + copy (t,System.length(t)-3,4);
+ end
+ else if UnicodeOutput and (c>#128) and (i#128) and (i
+ * Warning: This method assumes that the data structure is acyclical.
+ *
+ * @return a printable, displayable, portable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+function JSONObject.toString: string;
+var
+ _keys: TStringList;
+ o, sb: string;
+ i :integer;
+begin
+ _keys:=keys();
+ try
+ sb:='{';
+
+ for i:=0 to _keys.count -1 do
+ begin
+ if (System.length(sb) > 1) then
+ begin
+ sb:= sb + ',';
+ end;
+ o:=_keys[i];
+ if SimpleJSON and IsSimpString(o) then //By creation_zy
+ sb:=sb + o
+ else
+ sb:=sb + quote(o);
+ sb:=sb + ':';
+ sb:= sb + valueToString(TZAbstractObject(myHashMap.Objects[myHashMap.IndexOf(o)]));
+ end;
+ sb:=sb + '}';
+ Result:=sb;
+ finally
+ _keys.free;
+ end;
+end;
+
+
+(**
+ * Make a prettyprinted JSON external form string of this JSONObject.
+ *
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param indentFactor The number of spaces to add to each level of
+ * indentation.
+ * @return a printable, displayable, portable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+procedure JSONObject.SaveToStream(stream: TStream);
+var
+ _keys: TStringList;
+ o: string;
+ i, j :integer;
+begin
+ _keys:=keys();
+ try
+ WriteChar(stream, '{');
+ j := 1;
+ for i:=0 to _keys.count -1 do
+ begin
+ if (j > 1) then
+ WriteChar(stream, ',');
+ o:=_keys[i];
+ if SimpleJSON and IsSimpString(o) then //By creation_zy
+ WriteString(stream, o)
+ else
+ quoteToStream(stream, o);
+ WriteChar(stream, ':');
+ ValueToStream(TZAbstractObject(myHashMap.Objects[myHashMap.IndexOf(o)]), stream);
+ Inc(j);
+ end;
+ WriteChar(stream, '}');
+ finally
+ _keys.free;
+ end;
+end;
+
+function JSONObject.toString2(indentFactor: integer): string;
+begin
+ Result:=toString3(indentFactor, 0);
+end;
+
+(**
+ * Make a prettyprinted JSON string of this JSONObject.
+ *
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param indentFactor The number of spaces to add to each level of
+ * indentation.
+ * @param indent The indentation of the top level.
+ * @return a printable, displayable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+function JSONObject.toString3(indentFactor, indent: integer): string;
+var
+ j , n , newindent: integer;
+ _keys: TStringList;
+ o, sb: string;
+begin
+ //i:=0;
+ n:=length();
+ if (n = 0) then begin
+ Result:='{}';
+ exit;
+ end;
+ _keys:=keys();
+ try
+ sb:=sb + '{';
+ newindent:=indent + indentFactor;
+ if (n = 1) then
+ begin
+ o:=_keys[0];
+ sb:= sb + quote(o);
+ sb:= sb + ': ';
+ sb:= sb + valueToString(TZAbstractObject(myHashMap
+ .Objects[myHashMap.IndexOf(o)])
+ , indentFactor, indent);
+ end
+ else begin
+ for j:=0 to _keys.count -1 do
+ begin
+ o:=_keys[j];
+ if (System.length(sb) > 1) then
+ begin
+ sb:=sb + ','+ #10;
+ end
+ else begin
+ sb:= sb + #10;
+ end;
+ sb:= sb + SpaceStr(newindent) + quote(o) + ': ';
+ sb:= sb + valueToString(TZAbstractObject(myHashMap.Objects[myHashMap.IndexOf(o)])
+ , indentFactor, newindent);
+ end;
+ if (System.length(sb) > 1) then
+ begin
+ sb:=sb + #10;
+ sb:= sb + SpaceStr(indent);
+ end;
+ end;
+ sb:= sb + '}';
+ Result:=sb;
+ finally
+ _keys.Free; //Memory leak fixed. By creation_zy 2009-08-03
+ end;
+end;
+
+class function JSONObject.NULL: _NULL;
+begin
+ Result:=CNULL;
+end;
+
+(**
+ * Make JSON string of an object value.
+ *
+ * Warning: This method assumes that the data structure is acyclical.
+ * @param value The value to be serialized.
+ * @return a printable, displayable, transmittable
+ * representation of the object, beginning
+ * with { (left brace) and ending
+ * with } (right brace).
+ *)
+class function JSONObject.valueToString(value: TZAbstractObject): string;
+begin
+ if ((value = nil) or (value.equals(null))) then begin
+ Result:='null';
+ exit;
+ end;
+ if (value is _Number) then begin
+ Result:=numberToString(_Number(value));
+ exit;
+ end;
+ if ((value is _Boolean) or (value is JSONObject) or
+ (value is JSONArray)) then begin
+ Result:=value.toString();
+ exit;
+ end;
+ Result:=quote(value.toString());
+end;
+
+class procedure JSONObject.ValueToStream(value: TZAbstractObject;
+ stream: TStream);
+var
+ m: TStringStream;
+begin
+ if ((value = nil) or (value.equals(null))) then begin
+ WriteString(stream, 'null');
+ exit;
+ end;
+ if (value is _Number) then begin
+ WriteString(stream, numberToString(_Number(value)));
+ exit;
+ end;
+ if ((value is _Boolean) or (value is JSONObject) or
+ (value is JSONArray)) then begin
+ value.SaveToStream(stream);
+ exit;
+ end;
+ m := TStringStream.Create('');
+ try
+ value.SaveToStream(m);
+ quoteToStream(stream, m.DataString);
+ //WriteString(stream, quote(m.DataString));
+ finally
+ m.Free;
+ end;
+end;
+
+
+
+(**
+ * Make a prettyprinted JSON string of an object value.
+ *