1 ######################################################################
3 ### Copyright (c) 2009 Taylor Christopher Venable ###
4 ### Made available under the Simplified BSD License. ###
6 ######################################################################
8 # CVS Path: /Programs/Libraries/Tcl/tcvJSON/tcvJSON.tcl
10 # Revision: $Revision$
12 ## The parser part of this code is derived from that found in Tcllib, and which
13 ## bears this copyright information:
15 ## Copyright 2006 ActiveState Software Inc.
17 ## See also the accompanying license.terms file which describes the rules for
18 ## licensing and distributing Tcllib code.
20 package provide tcvJSON 1.0
22 namespace eval tcvJSON {}
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
36 # {list {str "quick brown fox"} {list {num 1} {num 2}}}
38 # --> ["quick brown fox", [1, 2]]
40 # In this scheme, objects are represented as follows:
42 # {obj "foo" {str "bar"} "tcl" {num 8.6}}
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.
50 proc tcvJSON::create {type} {
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.
68 proc tcvJSON::add! {args} {
74 if {[lindex $args 0] eq "-type"} {
75 set type [lindex $args 1]
79 set location [lindex $args [expr {$offset + 0}]]
80 set value [lindex $args [expr {$offset + 1}]]
82 if {![info exists type]} {
83 if {[string is double -strict $value]} {
85 } elseif {$value eq "true" || $value eq "false"} {
87 } elseif {$value eq "null"} {
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]
97 set value [lrange $value 1 end]
103 if {[lindex $json 0] ne "list"} {
104 error "can only \"add\" to lists: received $json"
107 if {$type eq "null"} {
110 if {$type eq "list" || $type eq "obj"} {
111 lappend json [list $type {*}$value]
113 lappend json [list $type $value]
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.
124 proc tcvJSON::put! {args} {
132 if {[lindex $args 0] eq "-type"} {
133 set type [lindex $args 1]
137 set location [lindex $args [expr {$offset + 0}]]
138 set key [lindex $args [expr {$offset + 1}]]
139 set value [lindex $args [expr {$offset + 2}]]
141 if {![info exists type]} {
142 if {[string is double -strict $value]} {
144 } elseif {$value eq "true" || $value eq "false"} {
146 } elseif {$value eq "null"} {
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]
156 set value [lrange $value 1 end]
162 if {[lindex $json 0] ne "obj"} {
163 error "can only \"put\" to objects: received $json"
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]
173 if {$type eq "null"} {
176 if {$type eq "list" || $type eq "obj"} {
177 lappend json [list $type {*}$value]
179 lappend json [list $type $value]
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.
189 proc tcvJSON::unparse {thing args} {
191 set type [lindex $thing 0]
196 if {[llength $args] > 0} {
197 set indent [lindex $args 0]
198 if {[llength $args] > 1} {
199 set indentIncr [lindex $args 1]
201 set indentIncr $indent
203 if {$indent == 0} { set nl "" }
208 append output "\[$nl[string repeat " " $indent]"
210 foreach element [lrange $thing 1 end] {
211 lappend tmp [unparse $element [expr {$indent + $indentIncr}] $indentIncr]
213 append output [join $tmp ",$nl[string repeat " " $indent]"]
214 append output "$nl[string repeat " " [expr {$indent - $indentIncr}]]\]"
218 append output "\{$nl[string repeat " " $indent]"
220 for {set i 1} {$i < [llength $thing]} {incr i} {
221 set key [lindex $thing $i]
222 set value [lindex $thing [incr i]]
223 lappend tmp "\"$key\": [unparse $value [expr {$indent + $indentIncr}] $indentIncr]"
225 append output [join $tmp ",\n[string repeat " " $indent]"]
226 append output "$nl[string repeat " " [expr {$indent - $indentIncr}]]\}"
230 append output "\"[lindex $thing 1]\""
235 append output "[lindex $thing 1]"
243 error "unknown type \"$type\""
249 proc tcvJSON::write {args} {
250 if {[llength $args] == 1} {
252 set jsonName [lindex $args 0]
253 } elseif {[llength $args] == 2} {
254 set channel [lindex $args 0]
255 set jsonName [lindex $args 1]
257 error "wrong # args: expected \"write ?channel? jsonName\""
261 puts $channel [unparse $json]
264 # Shamelessly lifted from Tcllib's json::getc proc.
266 proc tcvJSON::getc {{txtvar txt}} {
267 # pop single char off the front of the text
270 return -code error "unexpected end of text"
273 set c [string index $txt 0]
274 set txt [string range $txt 1 end]
278 proc tcvJSON::parse {txt} {
282 # Modified from Tcllib's json::_json2dict proc.
284 proc tcvJSON::Parse {{txtvar txt}} {
290 set txt [string trimleft $txt]
292 set c [string index $txt 0]
295 while {[string is space $c]} {
297 set c [string index $txt 0]
304 # This is the toplevel object.
307 set current [create obj]
310 # We are inside an object looking at the value, which is another object.
311 put! -type auto current $name [Parse]
315 # We are inside a list and the next element is an object.
316 add! -type auto current [Parse]
320 return -code error "unexpected open brace in $state mode"
323 } elseif {$c eq "\}"} {
325 if {$state ne "OBJECT" && $state ne "COMMA"} {
326 return -code error "unexpected close brace in $state mode"
329 } elseif {$c eq ":"} {
333 if {$state eq "COLON"} {
336 return -code error "unexpected colon in $state mode"
338 } elseif {$c eq ","} {
340 if {$state eq "COMMA"} {
342 if {[lindex $current 0] eq "list"} {
344 } elseif {[lindex $current 0] eq "obj"} {
348 return -code error "unexpected comma in $state mode"
350 } elseif {$c eq "\""} {
352 # capture quoted string with backslash sequences
353 set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
355 if {![regexp $reStr $txt string]} {
356 set txt [string replace $txt 32 end ...]
357 return -code error "invalid formatted string in $txt"
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]]
375 add! -type str current $string
379 put! -type str current $name $string
384 } elseif {$c eq "\["} {
385 # JSON array == Tcl list
389 set current [create list]
393 add! -type auto current [Parse]
397 put! -type auto current $name [Parse]
401 return -code error "unexpected open bracket in $state mode"
404 } elseif {$c eq "\]"} {
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
413 set num [string range $txt 0 [expr {$last - 1}]]
414 set txt [string range $txt $last end]
421 add! -type num current $num
425 put! -type num current $name $num
430 return -code error "unexpected number '$c' in $state mode"
435 return -code error "unexpected '$c' in $state mode"
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]
451 put! current $name $val
456 return -code error "unexpected '$c' in $state mode"
460 # error, incorrect format or unexpected end of text
461 return -code error "unexpected '$c' in $state mode"
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
471 proc tcvJSON::objForEach {k v obj script} {
472 if {[lindex $obj 0] ne "obj"} {
473 error "this is not an object"
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]]
482 if {[llength $obj] > 1} {
483 # Clean up after ourselves.
484 uplevel [list unset $k]
485 uplevel [list unset $v]
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.
494 proc tcvJSON::exists? {json thing} {
495 if {[lindex $json 0] eq "obj"} {
497 } elseif {[lindex $json 0] eq "list"} {
500 error "not a composite type"
502 for {set i 1} {$i < [llength $json]} {incr i $increment} {
503 if {[lindex $json $i] == $thing} {
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
515 proc tcvJSON::listForEach {e lst script} {
516 if {[lindex $lst 0] ne "list"} {
517 error "this is not a list"
520 for {set i 1} {$i < [llength $lst]} {incr i} {
521 uplevel [list set $e [lindex $obj $i]]
525 # Don't leave the variables set.
526 uplevel [list unset $e]