forked from CG-it/CG-it
-
Notifications
You must be signed in to change notification settings - Fork 0
/
json.tcl
282 lines (233 loc) · 7.05 KB
/
json.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
# json.tcl --
#
# JSON parser for Tcl. Management code, Tcl/C detection and selection.
#
# Copyright (c) 2013 by Andreas Kupries
# @mdgen EXCLUDE: jsonc.tcl
package require Tcl 8.4
namespace eval ::json {}
# ### ### ### ######### ######### #########
## Management of json implementations.
# ::json::LoadAccelerator --
#
# Loads a named implementation, if possible.
#
# Arguments:
# key Name of the implementation to load.
#
# Results:
# A boolean flag. True if the implementation
# was successfully loaded; and False otherwise.
proc ::json::LoadAccelerator {key} {
variable accel
set r 0
switch -exact -- $key {
critcl {
# Critcl implementation of json requires Tcl 8.4.
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
if {[catch {package require tcllibc}]} {return 0}
# Check for the jsonc 1.1.1 API we are fixing later.
set r [llength [info commands ::json::many_json2dict_critcl]]
}
tcl {
variable selfdir
source [file join $selfdir json_tcl.tcl]
set r 1
}
default {
return -code error "invalid accelerator/impl. package $key:\
must be one of [join [KnownImplementations] {, }]"
}
}
set accel($key) $r
return $r
}
# ::json::SwitchTo --
#
# Activates a loaded named implementation.
#
# Arguments:
# key Name of the implementation to activate.
#
# Results:
# None.
proc ::json::SwitchTo {key} {
variable accel
variable loaded
variable apicmds
if {[string equal $key $loaded]} {
# No change, nothing to do.
return
} elseif {![string equal $key ""]} {
# Validate the target implementation of the switch.
if {![info exists accel($key)]} {
return -code error "Unable to activate unknown implementation \"$key\""
} elseif {![info exists accel($key)] || !$accel($key)} {
return -code error "Unable to activate missing implementation \"$key\""
}
}
# Deactivate the previous implementation, if there was any.
if {![string equal $loaded ""]} {
foreach c $apicmds {
rename ::json::${c} ::json::${c}_$loaded
}
}
# Activate the new implementation, if there is any.
if {![string equal $key ""]} {
foreach c $apicmds {
rename ::json::${c}_$key ::json::${c}
}
}
# Remember the active implementation, for deactivation by future
# switches.
set loaded $key
return
}
# ::json::Implementations --
#
# Determines which implementations are
# present, i.e. loaded.
#
# Arguments:
# None.
#
# Results:
# A list of implementation keys.
proc ::json::Implementations {} {
variable accel
set res {}
foreach n [array names accel] {
if {!$accel($n)} continue
lappend res $n
}
return $res
}
# ::json::KnownImplementations --
#
# Determines which implementations are known
# as possible implementations.
#
# Arguments:
# None.
#
# Results:
# A list of implementation keys. In the order
# of preference, most prefered first.
proc ::json::KnownImplementations {} {
return {critcl tcl}
}
proc ::json::Names {} {
return {
critcl {tcllibc based}
tcl {pure Tcl}
}
}
# ### ### ### ######### ######### #########
## Initialization: Data structures.
namespace eval ::json {
variable selfdir [file dirname [info script]]
variable accel
array set accel {tcl 0 critcl 0}
variable loaded {}
variable apicmds {
json2dict
many-json2dict
}
}
# ### ### ### ######### ######### #########
## Wrapper fix for the jsonc package to match APIs.
proc ::json::many-json2dict_critcl {args} {
eval [linsert $args 0 ::json::many_json2dict_critcl]
}
# ### ### ### ######### ######### #########
## Initialization: Choose an implementation,
## most prefered first. Loads only one of the
## possible implementations. And activates it.
namespace eval ::json {
variable e
foreach e [KnownImplementations] {
if {[LoadAccelerator $e]} {
SwitchTo $e
break
}
}
unset e
}
# ### ### ### ######### ######### #########
## Tcl implementation of validation, shared for Tcl and C implementation.
##
## The regexp based validation is consistently faster than json-c.
## Suspected reasons: Tcl REs are mainly in C as well, and json-c has
## overhead in constructing its own data structures. While irrelevant
## to validation json-c still builds them, it has no mode doing pure
## syntax checking.
namespace eval ::json {
# Regular expression for tokenizing a JSON text (cf. http://json.org/)
# tokens consisting of a single character
variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," }
variable singleCharTokenRE "\[[join $singleCharTokens {}]\]"
# quoted string tokens
variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" "." }
variable escapedCharRE "\\\\(?:[join $escapableREs |])"
variable unescapedCharRE {[^\\\"]}
variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\""
# as above, for validation
variable escapableREsv { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" }
variable escapedCharREv "\\\\(?:[join $escapableREsv |])"
variable stringREv "\"(?:$escapedCharREv|$unescapedCharRE)*\""
# (unquoted) words
variable wordTokens { "true" "false" "null" }
variable wordTokenRE [join $wordTokens "|"]
# number tokens
# negative lookahead (?!0)[[:digit:]]+ might be more elegant, but
# would slow down tokenizing by a factor of up to 3!
variable positiveRE {[1-9][[:digit:]]*}
variable cardinalRE "-?(?:$positiveRE|0)"
variable fractionRE {[.][[:digit:]]+}
variable exponentialRE {[eE][+-]?[[:digit:]]+}
variable numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
# JSON token, and validation
variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE"
variable tokenREv "$singleCharTokenRE|$stringREv|$wordTokenRE|$numberRE"
# 0..n white space characters
set whiteSpaceRE {[[:space:]]*}
# Regular expression for validating a JSON text
variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenREv))*${whiteSpaceRE}$"
}
# Validate JSON text
# @param jsonText JSON text
# @return 1 iff $jsonText conforms to the JSON grammar
# (@see http://json.org/)
proc ::json::validate {jsonText} {
variable validJsonRE
return [regexp -- $validJsonRE $jsonText]
}
# ### ### ### ######### ######### #########
## These three procedures shared between Tcl and Critcl implementations.
## See also package "json::write".
proc ::json::dict2json {dictVal} {
# XXX: Currently this API isn't symmetrical, as to create proper
# XXX: JSON text requires type knowledge of the input data
set json ""
set prefix ""
foreach {key val} $dictVal {
# key must always be a string, val may be a number, string or
# bare word (true|false|null)
if {0 && ![string is double -strict $val]
&& ![regexp {^(?:true|false|null)$} $val]} {
set val "\"$val\""
}
append json "$prefix\"$key\": $val" \n
set prefix ,
}
return "\{${json}\}"
}
proc ::json::list2json {listVal} {
return "\[[join $listVal ,]\]"
}
proc ::json::string2json {str} {
return "\"$str\""
}
# ### ### ### ######### ######### #########
## Ready
package provide json 1.3.3