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]
195 if {[llength $args] > 0} {
196 set indent [lindex $args 0]
201 append output "\[\n[string repeat " " $indent]"
203 foreach element [lrange $thing 1 end] {
204 lappend tmp [unparse $element [expr {$indent + $indentIncr}]]
206 append output [join $tmp ",\n[string repeat " " $indent]"]
207 append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\]"
211 append output "\{\n[string repeat " " $indent]"
213 for {set i 1} {$i < [llength $thing]} {incr i} {
214 set key [lindex $thing $i]
215 set value [lindex $thing [incr i]]
216 lappend tmp "\"$key\": [unparse $value [expr {$indent + $indentIncr}]]"
218 append output [join $tmp ",\n[string repeat " " $indent]"]
219 append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\}"
223 append output "\"[lindex $thing 1]\""
228 append output "[lindex $thing 1]"
236 error "unknown type \"$type\""
242 proc tcvJSON::write {args} {
243 if {[llength $args] == 1} {
245 set jsonName [lindex $args 0]
246 } elseif {[llength $args] == 2} {
247 set channel [lindex $args 0]
248 set jsonName [lindex $args 1]
250 error "wrong # args: expected \"write ?channel? jsonName\""
254 puts $channel [unparse $json]
257 # Shamelessly lifted from Tcllib's json::getc proc.
259 proc tcvJSON::getc {{txtvar txt}} {
260 # pop single char off the front of the text
263 return -code error "unexpected end of text"
266 set c [string index $txt 0]
267 set txt [string range $txt 1 end]
271 proc tcvJSON::parse {txt} {
275 # Modified from Tcllib's json::_json2dict proc.
277 proc tcvJSON::Parse {{txtvar txt}} {
283 set txt [string trimleft $txt]
285 set c [string index $txt 0]
288 while {[string is space $c]} {
290 set c [string index $txt 0]
297 # This is the toplevel object.
300 set current [create obj]
303 # We are inside an object looking at the value, which is another object.
304 put! -type auto current $name [Parse]
308 # We are inside a list and the next element is an object.
309 add! -type auto current [Parse]
313 return -code error "unexpected open brace in $state mode"
316 } elseif {$c eq "\}"} {
318 if {$state ne "OBJECT" && $state ne "COMMA"} {
319 return -code error "unexpected close brace in $state mode"
322 } elseif {$c eq ":"} {
326 if {$state eq "COLON"} {
329 return -code error "unexpected colon in $state mode"
331 } elseif {$c eq ","} {
333 if {$state eq "COMMA"} {
335 if {[lindex $current 0] eq "list"} {
337 } elseif {[lindex $current 0] eq "obj"} {
341 return -code error "unexpected comma in $state mode"
343 } elseif {$c eq "\""} {
345 # capture quoted string with backslash sequences
346 set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
348 if {![regexp $reStr $txt string]} {
349 set txt [string replace $txt 32 end ...]
350 return -code error "invalid formatted string in $txt"
352 set txt [string range $txt [string length $string] end]
353 # chop off outer ""s and substitute backslashes
354 # This does more than the RFC-specified backslash sequences,
355 # but it does cover them all
356 set string [subst -nocommand -novariable \
357 [string range $string 1 end-1]]
368 add! -type str current $string
372 put! -type str current $name $string
377 } elseif {$c eq "\["} {
378 # JSON array == Tcl list
382 set current [create list]
386 add! -type auto current [Parse]
390 put! -type auto current $name [Parse]
394 return -code error "unexpected open bracket in $state mode"
397 } elseif {$c eq "\]"} {
401 } elseif {[string match {[-0-9]} $c]} {
402 # one last check for a number, no leading zeros allowed,
403 # but it may be 0.xxx
404 string is double -failindex last $txt
406 set num [string range $txt 0 [expr {$last - 1}]]
407 set txt [string range $txt $last end]
414 add! -type num current $num
418 put! -type num current $name $num
423 return -code error "unexpected number '$c' in $state mode"
428 return -code error "unexpected '$c' in $state mode"
430 } elseif {[string match {[ftn]} $c]
431 && [regexp {^(true|false|null)} $txt val]} {
432 # bare word value: true | false | null
433 set txt [string range $txt [string length $val] end]
444 put! current $name $val
449 return -code error "unexpected '$c' in $state mode"
453 # error, incorrect format or unexpected end of text
454 return -code error "unexpected '$c' in $state mode"
459 # Synopsis: objForEach KEY VALUE OBJ SCRIPT
460 # Iterates through the key/value pairs in the supplied JSON object OBJ and sets
461 # KEY and VALUE in the environment of SCRIPT, then running SCRIPT at the
464 proc tcvJSON::objForEach {k v obj script} {
465 if {[lindex $obj 0] ne "obj"} {
466 error "this is not an object"
469 for {set i 1} {$i < [llength $obj]} {incr i 2} {
470 uplevel [list set $k [lindex $obj $i]]
471 uplevel [list set $v [lindex $obj $i+1]]
475 if {[llength $obj] > 1} {
476 # Clean up after ourselves.
477 uplevel [list unset $k]
478 uplevel [list unset $v]
482 # Synopsis: exists? JSON THING
483 # Indicates whether THING exists within JSON. If JSON is an object, then we
484 # treat THING like a key. If JSON is a list, we treat THING like an element.
485 # It is an error for the value of JSON to be a non-composite type.
487 proc tcvJSON::exists? {json thing} {
488 if {[lindex $json 0] eq "obj"} {
490 } elseif {[lindex $json 0] eq "list"} {
493 error "not a composite type"
495 for {set i 1} {$i < [llength $json]} {incr i $increment} {
496 if {[lindex $json $i] == $thing} {
503 # Synopsis: listForEach ELT LIST SCRIPT
504 # Iterates through all the elements in the supplied JSON list LIST and sets ELT
505 # appropriately in the environment of SCRIPT, then running SCRIPT at the
508 proc tcvJSON::listForEach {e lst script} {
509 if {[lindex $lst 0] ne "list"} {
510 error "this is not a list"
513 for {set i 1} {$i < [llength $lst]} {incr i} {
514 uplevel [list set $e [lindex $obj $i]]
518 # Don't leave the variables set.
519 uplevel [list unset $e]