Commit | Line | Data |
458402ad |
1 | # |
2 | # JSON parser for Tcl. |
3 | # |
4 | # See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt |
5 | # |
6 | # Total rework of the code published with version number 1.0 by |
7 | # Thomas Maeder, Glue Software Engineering AG |
8 | # |
9 | # $Id: json.tcl,v 1.7 2011/11/10 21:05:58 andreas_kupries Exp $ |
10 | # |
11 | |
12 | if {![package vsatisfies [package provide Tcl] 8.5]} { |
13 | package require dict |
14 | } |
15 | |
16 | package provide json 1.1.2 |
17 | |
18 | namespace eval json { |
19 | # Regular expression for tokenizing a JSON text (cf. http://json.org/) |
20 | |
21 | # tokens consisting of a single character |
22 | variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," } |
23 | variable singleCharTokenRE "\[[join $singleCharTokens {}]\]" |
24 | |
25 | # quoted string tokens |
26 | variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" } |
27 | variable escapedCharRE "\\\\(?:[join $escapableREs |])" |
28 | variable unescapedCharRE {[^\\\"]} |
29 | variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\"" |
30 | |
31 | # (unquoted) words |
32 | variable wordTokens { "true" "false" "null" } |
33 | variable wordTokenRE [join $wordTokens "|"] |
34 | |
35 | # number tokens |
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)?" |
43 | |
44 | # JSON token |
45 | variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE" |
46 | |
47 | |
48 | # 0..n white space characters |
49 | set whiteSpaceRE {[[:space:]]*} |
50 | |
51 | # Regular expression for validating a JSON text |
52 | variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenRE))*${whiteSpaceRE}$" |
53 | } |
54 | |
55 | |
56 | # Validate JSON text |
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} { |
61 | variable validJsonRE |
62 | |
63 | return [regexp -- $validJsonRE $jsonText] |
64 | } |
65 | |
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} { |
70 | variable tokenRE |
71 | |
72 | set tokens [regexp -all -inline -- $tokenRE $jsonText] |
73 | set nrTokens [llength $tokens] |
74 | set tokenCursor 0 |
75 | return [parseValue $tokens $nrTokens tokenCursor] |
76 | } |
77 | |
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" |
81 | } |
82 | |
83 | # Get rid of the quotes surrounding a string token and substitute the |
84 | # real characters for escape sequences within it |
85 | # @param token |
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] |
90 | } |
91 | |
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 |
103 | |
104 | set token [lindex $tokens $tokenCursor] |
105 | incr tokenCursor |
106 | |
107 | set leadingChar [string index $token 0] |
108 | if {$leadingChar eq "\""} { |
109 | set memberName [unquoteUnescapeString $token] |
110 | |
111 | if {$tokenCursor == $nrTokens} { |
112 | unexpected $tokenCursor "END" "\":\"" |
113 | } else { |
114 | set token [lindex $tokens $tokenCursor] |
115 | incr tokenCursor |
116 | |
117 | if {$token eq ":"} { |
118 | set memberValue [parseValue $tokens $nrTokens tokenCursor] |
119 | dict set objectDict $memberName $memberValue |
120 | } else { |
121 | unexpected $tokenCursor $token "\":\"" |
122 | } |
123 | } |
124 | } else { |
125 | unexpected $tokenCursor $token "STRING" |
126 | } |
127 | } |
128 | |
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 |
140 | |
141 | while true { |
142 | parseObjectMember $tokens $nrTokens tokenCursor objectDict |
143 | |
144 | set token [lindex $tokens $tokenCursor] |
145 | incr tokenCursor |
146 | |
147 | switch -exact $token { |
148 | "," { |
149 | # continue |
150 | } |
151 | "\}" { |
152 | break |
153 | } |
154 | default { |
155 | unexpected $tokenCursor $token "\",\"|\"\}\"" |
156 | } |
157 | } |
158 | } |
159 | } |
160 | |
161 | # Parse an object |
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 |
169 | |
170 | if {$tokenCursor == $nrTokens} { |
171 | unexpected $tokenCursor "END" "OBJECT" |
172 | } else { |
173 | set result [dict create] |
174 | |
175 | set token [lindex $tokens $tokenCursor] |
176 | |
177 | if {$token eq "\}"} { |
178 | # empty object |
179 | incr tokenCursor |
180 | } else { |
181 | parseObjectMembers $tokens $nrTokens tokenCursor result |
182 | } |
183 | |
184 | return $result |
185 | } |
186 | } |
187 | |
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 |
198 | |
199 | while true { |
200 | lappend result [parseValue $tokens $nrTokens tokenCursor] |
201 | |
202 | if {$tokenCursor == $nrTokens} { |
203 | unexpected $tokenCursor "END" "\",\"|\"\]\"" |
204 | } else { |
205 | set token [lindex $tokens $tokenCursor] |
206 | incr tokenCursor |
207 | |
208 | switch -exact $token { |
209 | "," { |
210 | # continue |
211 | } |
212 | "\]" { |
213 | break |
214 | } |
215 | default { |
216 | unexpected $tokenCursor $token "\",\"|\"\]\"" |
217 | } |
218 | } |
219 | } |
220 | } |
221 | } |
222 | |
223 | # Parse an array |
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 |
231 | |
232 | if {$tokenCursor == $nrTokens} { |
233 | unexpected $tokenCursor "END" "ARRAY" |
234 | } else { |
235 | set result {} |
236 | |
237 | set token [lindex $tokens $tokenCursor] |
238 | |
239 | set leadingChar [string index $token 0] |
240 | if {$leadingChar eq "\]"} { |
241 | # empty array |
242 | incr tokenCursor |
243 | } else { |
244 | parseArrayElements $tokens $nrTokens tokenCursor result |
245 | } |
246 | |
247 | return $result |
248 | } |
249 | } |
250 | |
251 | # Parse a value |
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 |
259 | |
260 | if {$tokenCursor == $nrTokens} { |
261 | unexpected $tokenCursor "END" "VALUE" |
262 | } else { |
263 | set token [lindex $tokens $tokenCursor] |
264 | incr tokenCursor |
265 | |
266 | set leadingChar [string index $token 0] |
267 | switch -exact -- $leadingChar { |
268 | "\{" { |
269 | return [parseObject $tokens $nrTokens tokenCursor] |
270 | } |
271 | "\[" { |
272 | return [parseArray $tokens $nrTokens tokenCursor] |
273 | } |
274 | "\"" { |
275 | # quoted string |
276 | return [unquoteUnescapeString $token] |
277 | } |
278 | "t" - |
279 | "f" - |
280 | "n" { |
281 | # bare word: true, false or null |
282 | return $token |
283 | } |
284 | default { |
285 | # number? |
286 | if {[string is double -strict $token]} { |
287 | return $token |
288 | } else { |
289 | unexpected $tokenCursor $token "VALUE" |
290 | } |
291 | } |
292 | } |
293 | } |
294 | } |
295 | |
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 |
299 | set json "" |
300 | |
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]} { |
306 | set val "\"$val\"" |
307 | } |
308 | append json "\"$key\": $val," \n |
309 | } |
310 | |
311 | return "\{${json}\}" |
312 | } |
313 | |
314 | proc json::list2json {listVal} { |
315 | return "\[[join $listVal ,]\]" |
316 | } |
317 | |
318 | proc json::string2json {str} { |
319 | return "\"$str\"" |
320 | } |