4 # See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt
6 # Total rework of the code published with version number 1.0 by
7 # Thomas Maeder, Glue Software Engineering AG
9 # $Id: json.tcl,v 1.7 2011/11/10 21:05:58 andreas_kupries Exp $
12 if {![package vsatisfies [package provide Tcl] 8.5]} {
16 package provide json 1.1.2
19 # Regular expression for tokenizing a JSON text (cf. http://json.org/)
21 # tokens consisting of a single character
22 variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," }
23 variable singleCharTokenRE "\[[join $singleCharTokens {}]\]"
25 # quoted string tokens
26 variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" }
27 variable escapedCharRE "\\\\(?:[join $escapableREs |])"
28 variable unescapedCharRE {[^\\\"]}
29 variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\""
32 variable wordTokens { "true" "false" "null" }
33 variable wordTokenRE [join $wordTokens "|"]
36 # negative lookahead (?!0)[[:digit:]]+ might be more elegant, but
37 # would slow down tokenizing by a factor of up to 3!
38 variable positiveRE {[1-9][[:digit:]]*}
39 variable cardinalRE "-?(?:$positiveRE|0)"
40 variable fractionRE {[.][[:digit:]]+}
41 variable exponentialRE {[eE][+-]?[[:digit:]]+}
42 variable numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
45 variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE"
48 # 0..n white space characters
49 set whiteSpaceRE {[[:space:]]*}
51 # Regular expression for validating a JSON text
52 variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenRE))*${whiteSpaceRE}$"
57 # @param jsonText JSON text
58 # @return 1 iff $jsonText conforms to the JSON grammar
59 # (@see http://json.org/)
60 proc json::validate {jsonText} {
63 return [regexp -- $validJsonRE $jsonText]
66 # Parse JSON text into a dict
67 # @param jsonText JSON text
68 # @return dict (or list) containing the object represented by $jsonText
69 proc json::json2dict {jsonText} {
72 set tokens [regexp -all -inline -- $tokenRE $jsonText]
73 set nrTokens [llength $tokens]
75 return [parseValue $tokens $nrTokens tokenCursor]
78 # Throw an exception signaling an unexpected token
79 proc json::unexpected {tokenCursor token expected} {
80 return -code error "unexpected token \"$token\" at position $tokenCursor; expecting $expected"
83 # Get rid of the quotes surrounding a string token and substitute the
84 # real characters for escape sequences within it
86 # @return unquoted unescaped value of the string contained in $token
87 proc json::unquoteUnescapeString {token} {
88 set unquoted [string range $token 1 end-1]
89 return [subst -nocommands -novariables $unquoted]
92 # Parse an object member
93 # @param tokens list of tokens
94 # @param nrTokens length of $tokens
95 # @param tokenCursorName name (in caller's context) of variable
96 # holding current position in $tokens
97 # @param objectDictName name (in caller's context) of dict
98 # representing the JSON object of which to
99 # parse the next member
100 proc json::parseObjectMember {tokens nrTokens tokenCursorName objectDictName} {
101 upvar $tokenCursorName tokenCursor
102 upvar $objectDictName objectDict
104 set token [lindex $tokens $tokenCursor]
107 set leadingChar [string index $token 0]
108 if {$leadingChar eq "\""} {
109 set memberName [unquoteUnescapeString $token]
111 if {$tokenCursor == $nrTokens} {
112 unexpected $tokenCursor "END" "\":\""
114 set token [lindex $tokens $tokenCursor]
118 set memberValue [parseValue $tokens $nrTokens tokenCursor]
119 dict set objectDict $memberName $memberValue
121 unexpected $tokenCursor $token "\":\""
125 unexpected $tokenCursor $token "STRING"
129 # Parse the members of an object
130 # @param tokens list of tokens
131 # @param nrTokens length of $tokens
132 # @param tokenCursorName name (in caller's context) of variable
133 # holding current position in $tokens
134 # @param objectDictName name (in caller's context) of dict
135 # representing the JSON object of which to
136 # parse the next member
137 proc json::parseObjectMembers {tokens nrTokens tokenCursorName objectDictName} {
138 upvar $tokenCursorName tokenCursor
139 upvar $objectDictName objectDict
142 parseObjectMember $tokens $nrTokens tokenCursor objectDict
144 set token [lindex $tokens $tokenCursor]
147 switch -exact $token {
155 unexpected $tokenCursor $token "\",\"|\"\}\""
162 # @param tokens list of tokens
163 # @param nrTokens length of $tokens
164 # @param tokenCursorName name (in caller's context) of variable
165 # holding current position in $tokens
166 # @return parsed object (Tcl dict)
167 proc json::parseObject {tokens nrTokens tokenCursorName} {
168 upvar $tokenCursorName tokenCursor
170 if {$tokenCursor == $nrTokens} {
171 unexpected $tokenCursor "END" "OBJECT"
173 set result [dict create]
175 set token [lindex $tokens $tokenCursor]
177 if {$token eq "\}"} {
181 parseObjectMembers $tokens $nrTokens tokenCursor result
188 # Parse the elements of an array
189 # @param tokens list of tokens
190 # @param nrTokens length of $tokens
191 # @param tokenCursorName name (in caller's context) of variable
192 # holding current position in $tokens
193 # @param resultName name (in caller's context) of the list
194 # representing the JSON array
195 proc json::parseArrayElements {tokens nrTokens tokenCursorName resultName} {
196 upvar $tokenCursorName tokenCursor
197 upvar $resultName result
200 lappend result [parseValue $tokens $nrTokens tokenCursor]
202 if {$tokenCursor == $nrTokens} {
203 unexpected $tokenCursor "END" "\",\"|\"\]\""
205 set token [lindex $tokens $tokenCursor]
208 switch -exact $token {
216 unexpected $tokenCursor $token "\",\"|\"\]\""
224 # @param tokens list of tokens
225 # @param nrTokens length of $tokens
226 # @param tokenCursorName name (in caller's context) of variable
227 # holding current position in $tokens
228 # @return parsed array (Tcl list)
229 proc json::parseArray {tokens nrTokens tokenCursorName} {
230 upvar $tokenCursorName tokenCursor
232 if {$tokenCursor == $nrTokens} {
233 unexpected $tokenCursor "END" "ARRAY"
237 set token [lindex $tokens $tokenCursor]
239 set leadingChar [string index $token 0]
240 if {$leadingChar eq "\]"} {
244 parseArrayElements $tokens $nrTokens tokenCursor result
252 # @param tokens list of tokens
253 # @param nrTokens length of $tokens
254 # @param tokenCursorName name (in caller's context) of variable
255 # holding current position in $tokens
256 # @return parsed value (dict, list, string, number)
257 proc json::parseValue {tokens nrTokens tokenCursorName} {
258 upvar $tokenCursorName tokenCursor
260 if {$tokenCursor == $nrTokens} {
261 unexpected $tokenCursor "END" "VALUE"
263 set token [lindex $tokens $tokenCursor]
266 set leadingChar [string index $token 0]
267 switch -exact -- $leadingChar {
269 return [parseObject $tokens $nrTokens tokenCursor]
272 return [parseArray $tokens $nrTokens tokenCursor]
276 return [unquoteUnescapeString $token]
281 # bare word: true, false or null
286 if {[string is double -strict $token]} {
289 unexpected $tokenCursor $token "VALUE"
296 proc json::dict2json {dictVal} {
297 # XXX: Currently this API isn't symmetrical, as to create proper
298 # XXX: JSON text requires type knowledge of the input data
301 dict for {key val} $dictVal {
302 # key must always be a string, val may be a number, string or
303 # bare word (true|false|null)
304 if {0 && ![string is double -strict $val]
305 && ![regexp {^(?:true|false|null)$} $val]} {
308 append json "\"$key\": $val," \n
314 proc json::list2json {listVal} {
315 return "\[[join $listVal ,]\]"
318 proc json::string2json {str} {