currency_converter
alarming
autosfx
aysalia
calllib
checksum-tools
colormanager
cryptochat
decoder
delphiutils
distributed
dpcstudio
dpg2
fastphp
fileformats
filter_foundry
forest
gridgame
ht46f47_simulator
indexer_suite
ipe_artfile_utils
javautils
jumper
lightgame
logviewer
musikbox
mystic_house
oidconverter
oidinfo_api
oidinfo_new_design
oidplus
personal-webbase
php_antispam
php_clientchallenge
php_guestbook
php_utils
plumbers
prepend
recyclebinunit
simple_log_event
sokoban
spacemission
stackman
userdetect2
uuid_mac_utils
vgwhois
vnag
webcounter
winbugtracker
yt_downloader
BlueGrey
calm
Elegant
Català-Valencià – Catalan
中文 – Chinese (Simplified)
中文 – Chinese (Traditional)
Česky – Czech
Dansk – Danish
Nederlands – Dutch
English – English
Suomi – Finnish
Français – French
Deutsch – German
עברית – Hebrew
हिंदी – Hindi
Magyar – Hungarian
Bahasa Indonesia – Indonesian
Italiano – Italian
日本語 – Japanese
한국어 – Korean
Македонски – Macedonian
मराठी – Marathi
Norsk – Norwegian
Polski – Polish
Português – Portuguese
Português – Portuguese (Brazil)
Русский – Russian
Slovenčina – Slovak
Slovenščina – Slovenian
Español – Spanish
Svenska – Swedish
Türkçe – Turkish
Українська – Ukrainian
Oëzbekcha – Uzbek
Subversion Repositories
currency_converter
currency_converter
/
trunk
/
RTL
/
uLkJSON.pas
– Rev 2
Rev
Blame
|
Last modification
|
View Log
|
RSS feed
{
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 <organization> 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<idx
then
begin
fList
.
Items
[
iIndex
]
:
=
fList
.
Items
[
idx
]
;
fList
.
Delete
(
idx
)
;
end
else
begin
fList
.
Delete
(
iIndex
)
;
end
;
end
;
end
;
function
TlkJSONcustomlist
.
GetChild
(
idx
:
Integer
)
:
TlkJSONbase
;
begin
if
(
idx <
0
)
or
(
idx >
=
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<Count
)
and
(
FUseHash
)
then
begin
mth
:
=
TlkJSONobjectmethod
(
fList
.
Items
[
idx
]
)
;
ht
.
AddPair
(
mth
.
FName
,
idx
)
;
end
;
{$endif}
end
;
class
function
TlkJSONobject
.
Generate
(
AUseHash
:
Boolean
=
true
)
:
TlkJSONobject
;
begin
result
:
=
TlkJSONobject
.
Create
(
AUseHash
)
;
end
;
function
TlkJSONobject
.
OldGetField
(
nm
:
WideString
)
:
TlkJSONbase
;
var
mth
:
TlkJSONobjectmethod
;
i
:
Integer
;
begin
i
:
=
IndexOfName
(
nm
)
;
if
i
=
-
1
then
begin
result
:
=
nil
;
end
else
begin
// mth := TlkJSONobjectmethod(FValue[i]);
mth
:
=
TlkJSONobjectmethod
(
fList
.
Items
[
i
]
)
;
result
:
=
mth
.
FValue
;
end
;
end
;
function
TlkJSONobject
.
IndexOfName
(
const
aname
:
WideString
)
:
Integer
;
var
mth
:
TlkJSONobjectmethod
;
i
:
Integer
;
begin
if
not
FUseHash
then
begin
result
:
=
-
1
;
for
i
:
=
0
to
Count
-
1
do
begin
// mth := TlkJSONobjectmethod(FValue[i]);
mth
:
=
TlkJSONobjectmethod
(
fList
.
Items
[
i
]
)
;
if
mth
.
Name
=
aname
then
begin
result
:
=
i
;
break
;
end
;
end
;
end
else
begin
result
:
=
ht
.
IndexOf
(
aname
)
;
end
;
end
;
function
TlkJSONobject
.
IndexOfObject
(
aobj
:
TlkJSONbase
)
:
Integer
;
var
mth
:
TlkJSONobjectmethod
;
i
:
Integer
;
begin
result
:
=
-
1
;
for
i
:
=
0
to
Count
-
1
do
begin
// mth := TlkJSONobjectmethod(FValue[i]);
mth
:
=
TlkJSONobjectmethod
(
fList
.
Items
[
i
]
)
;
if
mth
.
FValue
=
aobj
then
begin
result
:
=
i
;
break
;
end
;
end
;
end
;
procedure
TlkJSONobject
.
OldSetField
(
nm
:
WideString
;
const
AValue
:
TlkJSONbase
)
;
var
mth
:
TlkJSONobjectmethod
;
i
:
Integer
;
begin
i
:
=
IndexOfName
(
nm
)
;
if
i <>
-
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
(
j<i
)
then
begin
ws
:
=
copy
(
txt
,
idx
,
j
-
idx
)
;
idx
:
=
j
;
fin
:
=
true
;
end
// if i>0 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<t
.
nm
then
result
:
=
del
(
t
.
left
)
else
begin
fdeleted
:
=
t
;
result
:
=
del
(
t
.
right
)
;
end
;
if
(
t
=
flast
)
and
(
fdeleted <> 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 ws<t.nm then
result := del(t.left)
else
begin
fdeleted := t;
result := del(t.right);
end;
if (t = flast) and (fdeleted<>fbottom) 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<tk
.
nm
then
tk
:
=
tk
.
left
else
tk
:
=
tk
.
right
;
end
;
end
;
function
TlkBalTree
.
Insert
(
const
ws
:
WideString
;
x
:
Integer
)
:
Boolean
;
function
ins
(
var
t
:
PlkBalNode
)
:
Boolean
;
begin
if
t
=
fbottom
then
begin
new
(
t
)
;
t
.
key
:
=
x
;
t
.
nm
:
=
ws
;
t
.
left
:
=
fbottom
;
t
.
right
:
=
fbottom
;
t
.
level
:
=
1
;
result
:
=
true
;
end
else
begin
if
ws < t
.
nm
then
result
:
=
ins
(
t
.
left
)
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
.