Commit | Line | Data |
867f23e8 |
1 | ###################################################################### |
2 | ### ### |
3 | ### Copyright (c) 2009 Taylor Christopher Venable ### |
4 | ### Made available under the Simplified BSD License. ### |
5 | ### ### |
6 | ###################################################################### |
7 | |
8 | # CVS Path: /Programs/Libraries/Tcl/tcvJSON/tcvJSON.tcl |
9 | # Last Change: $Date$ |
10 | # Revision: $Revision$ |
11 | |
12 | ## The parser part of this code is derived from that found in Tcllib, and which |
13 | ## bears this copyright information: |
14 | ## |
15 | ## Copyright 2006 ActiveState Software Inc. |
16 | ## |
17 | ## See also the accompanying license.terms file which describes the rules for |
18 | ## licensing and distributing Tcllib code. |
19 | |
20 | package provide tcvJSON 1.0 |
21 | |
22 | namespace eval tcvJSON {} |
23 | |
24 | # This namespace is called tcvJSON because json is already in tcllib and other |
25 | # programs which use this module may need to access that alternative json. The |
26 | # problem with tcllib's json is that it doesn't offer a way to write JSON, only |
27 | # to read it. The inherent difficulty here is that most Tcl values can be |
28 | # simultaneously representable by more than one type: most values can be shown |
29 | # as strings. Examples: "quick brown fox" is both a string and a list of three |
30 | # elements. Similarly, "true" is both a boolean (as interpreted by [expr]) and |
31 | # a string. So how do we encode such things? Well we punt on it and force |
32 | # data to be added to JSON via a special interface. This produces an internal |
33 | # representation of tuples {TYPE VALUE} where TYPE indicates how to show the |
34 | # data. For example, a list could be |
35 | # |
36 | # {list {str "quick brown fox"} {list {num 1} {num 2}}} |
37 | # |
38 | # --> ["quick brown fox", [1, 2]] |
39 | # |
40 | # In this scheme, objects are represented as follows: |
41 | # |
42 | # {obj "foo" {str "bar"} "tcl" {num 8.6}} |
43 | # |
44 | # --> {"foo" : "bar", |
45 | # "tcl" : 8.6} |
46 | # |
47 | # Because keys in objects can only be strings, there's no need to tag them as |
48 | # such. Thus, an object is a list of key-value pairs. |
49 | |
50 | proc tcvJSON::create {type} { |
51 | switch -- $type { |
52 | {list} { |
53 | return {list} |
54 | } |
55 | |
56 | {obj} - |
57 | {object} { |
58 | return {obj} |
59 | } |
60 | } |
61 | } |
62 | |
63 | # Synopsis: add! ?-type TYPE? JSONNAME VALUE |
64 | # Appends the VALUE (possibly explicitly qualified to be of the given TYPE) to |
65 | # the end of a JSON list stored in the caller in the variable JSONNAME. |
66 | # Signals an error if the value of JSONNAME is not a JSON list. |
67 | |
68 | proc tcvJSON::add! {args} { |
69 | set location "" |
70 | set value "" |
71 | |
72 | set offset 0 |
73 | |
74 | if {[lindex $args 0] eq "-type"} { |
75 | set type [lindex $args 1] |
76 | set offset 2 |
77 | } |
78 | |
79 | set location [lindex $args [expr {$offset + 0}]] |
80 | set value [lindex $args [expr {$offset + 1}]] |
81 | |
82 | if {![info exists type]} { |
83 | if {[string is double -strict $value]} { |
84 | set type "num" |
85 | } elseif {$value eq "true" || $value eq "false"} { |
86 | set type "bool" |
87 | } elseif {$value eq "null"} { |
88 | set type "null" |
89 | } else { |
90 | set type "str" |
91 | } |
92 | } elseif {$type eq "auto"} { |
93 | set type [lindex $value 0] |
94 | if {$type ne "list" && $type ne "obj"} { |
95 | set value [lindex $value 1] |
96 | } else { |
97 | set value [lrange $value 1 end] |
98 | } |
99 | } |
100 | |
101 | upvar $location json |
102 | |
103 | if {[lindex $json 0] ne "list"} { |
104 | error "can only \"add\" to lists: received $json" |
105 | } |
106 | |
107 | if {$type eq "null"} { |
108 | lappend json "null" |
109 | } else { |
110 | if {$type eq "list" || $type eq "obj"} { |
111 | lappend json [list $type {*}$value] |
112 | } else { |
113 | lappend json [list $type $value] |
114 | } |
115 | } |
116 | } |
117 | |
118 | # Synopsis: put! ?-type TYPE? JSONNAME KEY VALUE |
119 | # Adds the relationship KEY → VALUE (possibly explicitly qualified to be of the |
120 | # given TYPE) into the JSON object stored in the caller in the variable |
121 | # JSONNAME. Signals an error if the value of JSONNAME is not a JSON object. |
122 | # KEY is treated as a string, both internally and for encoding. |
123 | |
124 | proc tcvJSON::put! {args} { |
125 | set location "" |
126 | |
127 | set key "" |
128 | set value "" |
129 | |
130 | set offset 0 |
131 | |
132 | if {[lindex $args 0] eq "-type"} { |
133 | set type [lindex $args 1] |
134 | set offset 2 |
135 | } |
136 | |
137 | set location [lindex $args [expr {$offset + 0}]] |
138 | set key [lindex $args [expr {$offset + 1}]] |
139 | set value [lindex $args [expr {$offset + 2}]] |
140 | |
141 | if {![info exists type]} { |
142 | if {[string is double -strict $value]} { |
143 | set type "num" |
144 | } elseif {$value eq "true" || $value eq "false"} { |
145 | set type "bool" |
146 | } elseif {$value eq "null"} { |
147 | set type "null" |
148 | } else { |
149 | set type "str" |
150 | } |
151 | } elseif {$type eq "auto"} { |
152 | set type [lindex $value 0] |
153 | if {$type ne "list" && $type ne "obj"} { |
154 | set value [lindex $value 1] |
155 | } else { |
156 | set value [lrange $value 1 end] |
157 | } |
158 | } |
159 | |
160 | upvar $location json |
161 | |
162 | if {[lindex $json 0] ne "obj"} { |
163 | error "can only \"put\" to objects: received $json" |
164 | } |
165 | |
166 | for {set i 1} {$i < [llength $json]} {incr i 2} { |
167 | if {[lindex $json $i] eq $key} { |
168 | set json [lreplace $json $i $i+1] |
169 | } |
170 | } |
171 | |
172 | lappend json $key |
173 | if {$type eq "null"} { |
174 | lappend json null |
175 | } else { |
176 | if {$type eq "list" || $type eq "obj"} { |
177 | lappend json [list $type {*}$value] |
178 | } else { |
179 | lappend json [list $type $value] |
180 | } |
181 | } |
182 | } |
183 | |
184 | # Synopsis: unparse JSONTHING |
185 | # Encodes / writes / prints / unparses some kind of JSON composite or scalar |
186 | # value JSONTHING into a string representation which can be sent over the wire |
187 | # or written to a file. |
188 | |
189 | proc tcvJSON::unparse {thing args} { |
190 | set output "" |
191 | set type [lindex $thing 0] |
192 | set indent 2 |
193 | set indentIncr 2 |
1e0b6d5f |
194 | set nl "\n" |
867f23e8 |
195 | |
196 | if {[llength $args] > 0} { |
197 | set indent [lindex $args 0] |
c2a818a9 |
198 | if {[llength $args] > 1} { |
199 | set indentIncr [lindex $args 1] |
200 | } else { |
201 | set indentIncr $indent |
202 | } |
1e0b6d5f |
203 | if {$indent == 0} { set nl "" } |
867f23e8 |
204 | } |
205 | |
206 | switch -- $type { |
207 | {list} { |
1e0b6d5f |
208 | append output "\[$nl[string repeat " " $indent]" |
867f23e8 |
209 | set tmp {} |
210 | foreach element [lrange $thing 1 end] { |
c2a818a9 |
211 | lappend tmp [unparse $element [expr {$indent + $indentIncr}] $indentIncr] |
867f23e8 |
212 | } |
1e0b6d5f |
213 | append output [join $tmp ",$nl[string repeat " " $indent]"] |
214 | append output "$nl[string repeat " " [expr {$indent - $indentIncr}]]\]" |
867f23e8 |
215 | } |
216 | |
217 | {obj} { |
1e0b6d5f |
218 | append output "\{$nl[string repeat " " $indent]" |
867f23e8 |
219 | set tmp {} |
220 | for {set i 1} {$i < [llength $thing]} {incr i} { |
221 | set key [lindex $thing $i] |
222 | set value [lindex $thing [incr i]] |
c2a818a9 |
223 | lappend tmp "\"$key\": [unparse $value [expr {$indent + $indentIncr}] $indentIncr]" |
867f23e8 |
224 | } |
225 | append output [join $tmp ",\n[string repeat " " $indent]"] |
1e0b6d5f |
226 | append output "$nl[string repeat " " [expr {$indent - $indentIncr}]]\}" |
867f23e8 |
227 | } |
228 | |
229 | {str} { |
230 | append output "\"[lindex $thing 1]\"" |
231 | } |
232 | |
233 | {bool} - |
234 | {num} { |
235 | append output "[lindex $thing 1]" |
236 | } |
237 | |
238 | {null} { |
239 | append output "null" |
240 | } |
241 | |
242 | {default} { |
243 | error "unknown type \"$type\"" |
244 | } |
245 | } |
246 | return $output |
247 | } |
248 | |
249 | proc tcvJSON::write {args} { |
250 | if {[llength $args] == 1} { |
251 | set channel stdout |
252 | set jsonName [lindex $args 0] |
253 | } elseif {[llength $args] == 2} { |
254 | set channel [lindex $args 0] |
255 | set jsonName [lindex $args 1] |
256 | } else { |
257 | error "wrong # args: expected \"write ?channel? jsonName\"" |
258 | } |
259 | |
260 | upvar $jsonName json |
261 | puts $channel [unparse $json] |
262 | } |
263 | |
264 | # Shamelessly lifted from Tcllib's json::getc proc. |
265 | |
266 | proc tcvJSON::getc {{txtvar txt}} { |
267 | # pop single char off the front of the text |
268 | upvar 1 $txtvar txt |
269 | if {$txt eq ""} { |
270 | return -code error "unexpected end of text" |
271 | } |
272 | |
273 | set c [string index $txt 0] |
274 | set txt [string range $txt 1 end] |
275 | return $c |
276 | } |
277 | |
278 | proc tcvJSON::parse {txt} { |
279 | return [Parse] |
280 | } |
281 | |
282 | # Modified from Tcllib's json::_json2dict proc. |
283 | |
284 | proc tcvJSON::Parse {{txtvar txt}} { |
285 | upvar 1 $txtvar txt |
286 | |
287 | set state TOP |
288 | set current {} |
289 | |
290 | set txt [string trimleft $txt] |
291 | while {$txt ne ""} { |
292 | set c [string index $txt 0] |
293 | |
294 | # skip whitespace |
295 | while {[string is space $c]} { |
296 | getc |
297 | set c [string index $txt 0] |
298 | } |
299 | |
300 | if {$c eq "\{"} { |
301 | # object |
302 | switch -- $state { |
303 | TOP { |
304 | # This is the toplevel object. |
305 | getc |
306 | set state OBJECT |
307 | set current [create obj] |
308 | } |
309 | VALUE { |
310 | # We are inside an object looking at the value, which is another object. |
311 | put! -type auto current $name [Parse] |
312 | set state COMMA |
313 | } |
314 | LIST { |
315 | # We are inside a list and the next element is an object. |
316 | add! -type auto current [Parse] |
317 | set state COMMA |
318 | } |
319 | default { |
320 | return -code error "unexpected open brace in $state mode" |
321 | } |
322 | } |
323 | } elseif {$c eq "\}"} { |
324 | getc |
325 | if {$state ne "OBJECT" && $state ne "COMMA"} { |
326 | return -code error "unexpected close brace in $state mode" |
327 | } |
328 | return $current |
329 | } elseif {$c eq ":"} { |
330 | # name separator |
331 | getc |
332 | |
333 | if {$state eq "COLON"} { |
334 | set state VALUE |
335 | } else { |
336 | return -code error "unexpected colon in $state mode" |
337 | } |
338 | } elseif {$c eq ","} { |
339 | # element separator |
340 | if {$state eq "COMMA"} { |
341 | getc |
342 | if {[lindex $current 0] eq "list"} { |
343 | set state LIST |
344 | } elseif {[lindex $current 0] eq "obj"} { |
345 | set state OBJECT |
346 | } |
347 | } else { |
348 | return -code error "unexpected comma in $state mode" |
349 | } |
350 | } elseif {$c eq "\""} { |
351 | # string |
352 | # capture quoted string with backslash sequences |
353 | set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))} |
354 | set string "" |
355 | if {![regexp $reStr $txt string]} { |
356 | set txt [string replace $txt 32 end ...] |
357 | return -code error "invalid formatted string in $txt" |
358 | } |
359 | set txt [string range $txt [string length $string] end] |
360 | # chop off outer ""s and substitute backslashes |
361 | # This does more than the RFC-specified backslash sequences, |
362 | # but it does cover them all |
363 | set string [subst -nocommand -novariable \ |
364 | [string range $string 1 end-1]] |
365 | |
366 | switch -- $state { |
367 | TOP { |
368 | return $string |
369 | } |
370 | OBJECT { |
371 | set name $string |
372 | set state COLON |
373 | } |
374 | LIST { |
375 | add! -type str current $string |
376 | set state COMMA |
377 | } |
378 | VALUE { |
379 | put! -type str current $name $string |
380 | unset name |
381 | set state COMMA |
382 | } |
383 | } |
384 | } elseif {$c eq "\["} { |
385 | # JSON array == Tcl list |
386 | switch -- $state { |
387 | TOP { |
388 | getc |
389 | set current [create list] |
390 | set state LIST |
391 | } |
392 | LIST { |
393 | add! -type auto current [Parse] |
394 | set state COMMA |
395 | } |
396 | VALUE { |
397 | put! -type auto current $name [Parse] |
398 | set state COMMA |
399 | } |
400 | default { |
401 | return -code error "unexpected open bracket in $state mode" |
402 | } |
403 | } |
404 | } elseif {$c eq "\]"} { |
405 | # end of list |
406 | getc |
407 | return $current |
408 | } elseif {[string match {[-0-9]} $c]} { |
409 | # one last check for a number, no leading zeros allowed, |
410 | # but it may be 0.xxx |
411 | string is double -failindex last $txt |
412 | if {$last > 0} { |
413 | set num [string range $txt 0 [expr {$last - 1}]] |
414 | set txt [string range $txt $last end] |
415 | |
416 | switch -- $state { |
417 | TOP { |
418 | return $num |
419 | } |
420 | LIST { |
421 | add! -type num current $num |
422 | set state COMMA |
423 | } |
424 | VALUE { |
425 | put! -type num current $name $num |
426 | set state COMMA |
427 | } |
428 | default { |
429 | getc |
430 | return -code error "unexpected number '$c' in $state mode" |
431 | } |
432 | } |
433 | } else { |
434 | getc |
435 | return -code error "unexpected '$c' in $state mode" |
436 | } |
437 | } elseif {[string match {[ftn]} $c] |
438 | && [regexp {^(true|false|null)} $txt val]} { |
439 | # bare word value: true | false | null |
440 | set txt [string range $txt [string length $val] end] |
441 | |
442 | switch -- $state { |
443 | TOP { |
444 | return $val |
445 | } |
446 | LIST { |
447 | add! current $val |
448 | set state COMMA |
449 | } |
450 | VALUE { |
451 | put! current $name $val |
452 | set state COMMA |
453 | } |
454 | default { |
455 | getc |
456 | return -code error "unexpected '$c' in $state mode" |
457 | } |
458 | } |
459 | } else { |
460 | # error, incorrect format or unexpected end of text |
461 | return -code error "unexpected '$c' in $state mode" |
462 | } |
463 | } |
464 | } |
465 | |
466 | # Synopsis: objForEach KEY VALUE OBJ SCRIPT |
467 | # Iterates through the key/value pairs in the supplied JSON object OBJ and sets |
468 | # KEY and VALUE in the environment of SCRIPT, then running SCRIPT at the |
469 | # caller's level. |
470 | |
471 | proc tcvJSON::objForEach {k v obj script} { |
472 | if {[lindex $obj 0] ne "obj"} { |
473 | error "this is not an object" |
474 | } |
475 | |
476 | for {set i 1} {$i < [llength $obj]} {incr i 2} { |
477 | uplevel [list set $k [lindex $obj $i]] |
478 | uplevel [list set $v [lindex $obj $i+1]] |
479 | uplevel $script |
480 | } |
481 | |
482 | if {[llength $obj] > 1} { |
483 | # Clean up after ourselves. |
484 | uplevel [list unset $k] |
485 | uplevel [list unset $v] |
486 | } |
487 | } |
488 | |
489 | # Synopsis: exists? JSON THING |
490 | # Indicates whether THING exists within JSON. If JSON is an object, then we |
491 | # treat THING like a key. If JSON is a list, we treat THING like an element. |
492 | # It is an error for the value of JSON to be a non-composite type. |
493 | |
494 | proc tcvJSON::exists? {json thing} { |
495 | if {[lindex $json 0] eq "obj"} { |
496 | set increment 2 |
497 | } elseif {[lindex $json 0] eq "list"} { |
498 | set increment 1 |
499 | } else { |
500 | error "not a composite type" |
501 | } |
502 | for {set i 1} {$i < [llength $json]} {incr i $increment} { |
503 | if {[lindex $json $i] == $thing} { |
504 | return 1 |
505 | } |
506 | } |
507 | return 0 |
508 | } |
509 | |
510 | # Synopsis: listForEach ELT LIST SCRIPT |
511 | # Iterates through all the elements in the supplied JSON list LIST and sets ELT |
512 | # appropriately in the environment of SCRIPT, then running SCRIPT at the |
513 | # caller's level. |
514 | |
515 | proc tcvJSON::listForEach {e lst script} { |
516 | if {[lindex $lst 0] ne "list"} { |
517 | error "this is not a list" |
518 | } |
519 | |
520 | for {set i 1} {$i < [llength $lst]} {incr i} { |
521 | uplevel [list set $e [lindex $obj $i]] |
522 | uplevel $script |
523 | } |
524 | |
525 | # Don't leave the variables set. |
526 | uplevel [list unset $e] |
527 | } |