[scpubgit/TenDotTcl.git] / tcvJSON.tcl

######################################################################
###                                                                ###
###  Copyright (c) 2009 Taylor Christopher Venable                 ###
###  Made available under the Simplified BSD License.              ###
###                                                                ###
######################################################################

# CVS Path: /Programs/Libraries/Tcl/tcvJSON/tcvJSON.tcl
# Last Change: $Date$
# Revision: $Revision$

## The parser part of this code is derived from that found in Tcllib, and which
## bears this copyright information:
##
## Copyright 2006 ActiveState Software Inc.
##
## See also the accompanying license.terms file which describes the rules for
## licensing and distributing Tcllib code.

package provide tcvJSON 1.0

namespace eval tcvJSON {}

# This namespace is called tcvJSON because json is already in tcllib and other
# programs which use this module may need to access that alternative json.  The
# problem with tcllib's json is that it doesn't offer a way to write JSON, only
# to read it.  The inherent difficulty here is that most Tcl values can be
# simultaneously representable by more than one type: most values can be shown
# as strings.  Examples: "quick brown fox" is both a string and a list of three
# elements.  Similarly, "true" is both a boolean (as interpreted by [expr]) and
# a string.  So how do we encode such things?  Well we punt on it and force
# data to be added to JSON via a special interface.  This produces an internal
# representation of tuples {TYPE VALUE} where TYPE indicates how to show the
# data.  For example, a list could be
#
# {list {str "quick brown fox"} {list {num 1} {num 2}}}
#
# --> ["quick brown fox", [1, 2]]
#
# In this scheme, objects are represented as follows:
#
# {obj "foo" {str "bar"} "tcl" {num 8.6}}
#
# --> {"foo" : "bar",
#      "tcl" : 8.6}
#
# Because keys in objects can only be strings, there's no need to tag them as
# such.  Thus, an object is a list of key-value pairs.

proc tcvJSON::create {type} {
    switch -- $type {
        {list} {
            return {list}
        }

        {obj} -
        {object} {
            return {obj}
        }
    }
}

# Synopsis: add! ?-type TYPE? JSONNAME VALUE
# Appends the VALUE (possibly explicitly qualified to be of the given TYPE) to
# the end of a JSON list stored in the caller in the variable JSONNAME.
# Signals an error if the value of JSONNAME is not a JSON list.

proc tcvJSON::add! {args} {
    set location ""
    set value ""

    set offset 0

    if {[lindex $args 0] eq "-type"} {
        set type [lindex $args 1]
        set offset 2
    }

    set location [lindex $args [expr {$offset + 0}]]
    set value [lindex $args [expr {$offset + 1}]]

    if {![info exists type]} {
        if {[string is double -strict $value]} {
            set type "num"
        } elseif {$value eq "true" || $value eq "false"} {
            set type "bool"
        } elseif {$value eq "null"} {
            set type "null"
        } else {
            set type "str"
        }
    } elseif {$type eq "auto"} {
        set type [lindex $value 0]
        if {$type ne "list" && $type ne "obj"} {
            set value [lindex $value 1]
        } else {
            set value [lrange $value 1 end]
        }
    }

    upvar $location json

    if {[lindex $json 0] ne "list"} {
        error "can only \"add\" to lists: received $json"
    }

    if {$type eq "null"} {
        lappend json "null"
    } else {
        if {$type eq "list" || $type eq "obj"} {
            lappend json [list $type {*}$value]
        } else {
            lappend json [list $type $value]
        }
    }
}

# Synopsis: put! ?-type TYPE? JSONNAME KEY VALUE
# Adds the relationship KEY → VALUE (possibly explicitly qualified to be of the
# given TYPE) into the JSON object stored in the caller in the variable
# JSONNAME.  Signals an error if the value of JSONNAME is not a JSON object.
# KEY is treated as a string, both internally and for encoding.

proc tcvJSON::put! {args} {
    set location ""

    set key ""
    set value ""

    set offset 0

    if {[lindex $args 0] eq "-type"} {
        set type [lindex $args 1]
        set offset 2
    }

    set location [lindex $args [expr {$offset + 0}]]
    set key [lindex $args [expr {$offset + 1}]]
    set value [lindex $args [expr {$offset + 2}]]

    if {![info exists type]} {
        if {[string is double -strict $value]} {
            set type "num"
        } elseif {$value eq "true" || $value eq "false"} {
            set type "bool"
        } elseif {$value eq "null"} {
            set type "null"
        } else {
            set type "str"
        }
    } elseif {$type eq "auto"} {
        set type [lindex $value 0]
        if {$type ne "list" && $type ne "obj"} {
            set value [lindex $value 1]
        } else {
            set value [lrange $value 1 end]
        }
    }

    upvar $location json

    if {[lindex $json 0] ne "obj"} {
        error "can only \"put\" to objects: received $json"
    }

    for {set i 1} {$i < [llength $json]} {incr i 2} {
        if {[lindex $json $i] eq $key} {
            set json [lreplace $json $i $i+1]
        }
    }

    lappend json $key
    if {$type eq "null"} {
        lappend json null
    } else {
        if {$type eq "list" || $type eq "obj"} {
            lappend json [list $type {*}$value]
        } else {
            lappend json [list $type $value]
        }
    }
}

# Synopsis: unparse JSONTHING
# Encodes / writes / prints / unparses some kind of JSON composite or scalar
# value JSONTHING into a string representation which can be sent over the wire
# or written to a file.

proc tcvJSON::unparse {thing args} {
    set output ""
    set type [lindex $thing 0]
    set indent 2
    set indentIncr 2

    if {[llength $args] > 0} {
        set indent [lindex $args 0]
    }

    switch -- $type {
        {list} {
            append output "\[\n[string repeat " " $indent]"
            set tmp {}
            foreach element [lrange $thing 1 end] {
                lappend tmp [unparse $element [expr {$indent + $indentIncr}]]
            }
            append output [join $tmp ",\n[string repeat " " $indent]"]
            append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\]"
        }

        {obj} {
            append output "\{\n[string repeat " " $indent]"
            set tmp {}
            for {set i 1} {$i < [llength $thing]} {incr i} {
                set key [lindex $thing $i]
                set value [lindex $thing [incr i]]
                lappend tmp "\"$key\": [unparse $value [expr {$indent + $indentIncr}]]"
            }
            append output [join $tmp ",\n[string repeat " " $indent]"]
            append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\}"
        }

        {str} {
            append output "\"[lindex $thing 1]\""
        }

        {bool} -
        {num} {
            append output "[lindex $thing 1]"
        }

        {null} {
            append output "null"
        }

        {default} {
            error "unknown type \"$type\""
        }
    }
    return $output
}

proc tcvJSON::write {args} {
    if {[llength $args] == 1} {
        set channel stdout
        set jsonName [lindex $args 0]
    } elseif {[llength $args] == 2} {
        set channel [lindex $args 0]
        set jsonName [lindex $args 1]
    } else {
        error "wrong # args: expected \"write ?channel? jsonName\""
    }

    upvar $jsonName json
    puts $channel [unparse $json]
}

# Shamelessly lifted from Tcllib's json::getc proc.

proc tcvJSON::getc {{txtvar txt}} {
    # pop single char off the front of the text
    upvar 1 $txtvar txt
    if {$txt eq ""} {
        return -code error "unexpected end of text"
    }

    set c [string index $txt 0]
    set txt [string range $txt 1 end]
    return $c
}

proc tcvJSON::parse {txt} {
    return [Parse]
}

# Modified from Tcllib's json::_json2dict proc.

proc tcvJSON::Parse {{txtvar txt}} {
    upvar 1 $txtvar txt

    set state TOP
    set current {}

    set txt [string trimleft $txt]
    while {$txt ne ""} {
        set c [string index $txt 0]

        # skip whitespace
        while {[string is space $c]} {
            getc
            set c [string index $txt 0]
        }

        if {$c eq "\{"} {
            # object
            switch -- $state {
                TOP {
                    # This is the toplevel object.
                    getc
                    set state OBJECT
                    set current [create obj]
                }
                VALUE {
                    # We are inside an object looking at the value, which is another object.
                    put! -type auto current $name [Parse]
                    set state COMMA
                }
                LIST {
                    # We are inside a list and the next element is an object.
                    add! -type auto current [Parse]
                    set state COMMA
                }
                default {
                    return -code error "unexpected open brace in $state mode"
                }
            }
        } elseif {$c eq "\}"} {
            getc
            if {$state ne "OBJECT" && $state ne "COMMA"} {
                return -code error "unexpected close brace in $state mode"
            }
            return $current
        } elseif {$c eq ":"} {
            # name separator
            getc

            if {$state eq "COLON"} {
                set state VALUE
            } else {
                return -code error "unexpected colon in $state mode"
            }
        } elseif {$c eq ","} {
            # element separator
            if {$state eq "COMMA"} {
                getc
                if {[lindex $current 0] eq "list"} {
                    set state LIST
                } elseif {[lindex $current 0] eq "obj"} {
                    set state OBJECT
                }
            } else {
                return -code error "unexpected comma in $state mode"
            }
        } elseif {$c eq "\""} {
            # string
            # capture quoted string with backslash sequences
            set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
            set string ""
            if {![regexp $reStr $txt string]} {
                set txt [string replace $txt 32 end ...]
                return -code error "invalid formatted string in $txt"
            }
            set txt [string range $txt [string length $string] end]
            # chop off outer ""s and substitute backslashes
            # This does more than the RFC-specified backslash sequences,
            # but it does cover them all
            set string [subst -nocommand -novariable \
                            [string range $string 1 end-1]]

            switch -- $state {
                TOP {
                    return $string
                }
                OBJECT {
                    set name $string
                    set state COLON
                }
                LIST {
                    add! -type str current $string
                    set state COMMA
                }
                VALUE {
                    put! -type str current $name $string
                    unset name
                    set state COMMA
                }
            }
        } elseif {$c eq "\["} {
            # JSON array == Tcl list
            switch -- $state {
                TOP {
                    getc
                    set current [create list]
                    set state LIST
                }
                LIST {
                    add! -type auto current [Parse]
                    set state COMMA
                }
                VALUE {
                    put! -type auto current $name [Parse]
                    set state COMMA
                }
                default {
                    return -code error "unexpected open bracket in $state mode"
                }
            }
        } elseif {$c eq "\]"} {
            # end of list
            getc
            return $current
        } elseif {[string match {[-0-9]} $c]} {
            # one last check for a number, no leading zeros allowed,
            # but it may be 0.xxx
            string is double -failindex last $txt
            if {$last > 0} {
                set num [string range $txt 0 [expr {$last - 1}]]
                set txt [string range $txt $last end]

                switch -- $state {
                    TOP {
                        return $num
                    }
                    LIST {
                        add! -type num current $num
                        set state COMMA
                    }
                    VALUE {
                        put! -type num current $name $num
                        set state COMMA
                    }
                    default {
                        getc
                        return -code error "unexpected number '$c' in $state mode"
                    }
                }
            } else {
                getc
                return -code error "unexpected '$c' in $state mode"
            }
        } elseif {[string match {[ftn]} $c]
                  && [regexp {^(true|false|null)} $txt val]} {
            # bare word value: true | false | null
            set txt [string range $txt [string length $val] end]

            switch -- $state {
                TOP {
                    return $val
                }
                LIST {
                    add! current $val
                    set state COMMA
                }
                VALUE {
                    put! current $name $val
                    set state COMMA
                }
                default {
                    getc
                    return -code error "unexpected '$c' in $state mode"
                }
            }
        } else {
            # error, incorrect format or unexpected end of text
            return -code error "unexpected '$c' in $state mode"
        }
    }
}

# Synopsis: objForEach KEY VALUE OBJ SCRIPT
# Iterates through the key/value pairs in the supplied JSON object OBJ and sets
# KEY and VALUE in the environment of SCRIPT, then running SCRIPT at the
# caller's level.

proc tcvJSON::objForEach {k v obj script} {
    if {[lindex $obj 0] ne "obj"} {
        error "this is not an object"
    }

    for {set i 1} {$i < [llength $obj]} {incr i 2} {
        uplevel [list set $k [lindex $obj $i]]
        uplevel [list set $v [lindex $obj $i+1]]
        uplevel $script
    }

    if {[llength $obj] > 1} {
        # Clean up after ourselves.
        uplevel [list unset $k]
        uplevel [list unset $v]
    }
}

# Synopsis: exists? JSON THING
# Indicates whether THING exists within JSON.  If JSON is an object, then we
# treat THING like a key.  If JSON is a list, we treat THING like an element.
# It is an error for the value of JSON to be a non-composite type.

proc tcvJSON::exists? {json thing} {
    if {[lindex $json 0] eq "obj"} {
        set increment 2
    } elseif {[lindex $json 0] eq "list"} {
        set increment 1
    } else {
        error "not a composite type"
    }
    for {set i 1} {$i < [llength $json]} {incr i $increment} {
        if {[lindex $json $i] == $thing} {
            return 1
        }
    }
    return 0
}

# Synopsis: listForEach ELT LIST SCRIPT
# Iterates through all the elements in the supplied JSON list LIST and sets ELT
# appropriately in the environment of SCRIPT, then running SCRIPT at the
# caller's level.

proc tcvJSON::listForEach {e lst script} {
    if {[lindex $lst 0] ne "list"} {
        error "this is not a list"
    }

    for {set i 1} {$i < [llength $lst]} {incr i} {
        uplevel [list set $e [lindex $obj $i]]
        uplevel $script
    }

    # Don't leave the variables set.
    uplevel [list unset $e]
}
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
194
195	if {[llength $args] > 0} {
196	set indent [lindex $args 0]
197	}
198
199	switch -- $type {
200	{list} {
201	append output "\[\n[string repeat " " $indent]"
202	set tmp {}
203	foreach element [lrange $thing 1 end] {
204	lappend tmp [unparse $element [expr {$indent + $indentIncr}]]
205	}
206	append output [join $tmp ",\n[string repeat " " $indent]"]
207	append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\]"
208	}
209
210	{obj} {
211	append output "\{\n[string repeat " " $indent]"
212	set tmp {}
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}]]"
217	}
218	append output [join $tmp ",\n[string repeat " " $indent]"]
219	append output "\n[string repeat " " [expr {$indent - $indentIncr}]]\}"
220	}
221
222	{str} {
223	append output "\"[lindex $thing 1]\""
224	}
225
226	{bool} -
227	{num} {
228	append output "[lindex $thing 1]"
229	}
230
231	{null} {
232	append output "null"
233	}
234
235	{default} {
236	error "unknown type \"$type\""
237	}
238	}
239	return $output
240	}
241
242	proc tcvJSON::write {args} {
243	if {[llength $args] == 1} {
244	set channel stdout
245	set jsonName [lindex $args 0]
246	} elseif {[llength $args] == 2} {
247	set channel [lindex $args 0]
248	set jsonName [lindex $args 1]
249	} else {
250	error "wrong # args: expected \"write ?channel? jsonName\""
251	}
252
253	upvar $jsonName json
254	puts $channel [unparse $json]
255	}
256
257	# Shamelessly lifted from Tcllib's json::getc proc.
258
259	proc tcvJSON::getc {{txtvar txt}} {
260	# pop single char off the front of the text
261	upvar 1 $txtvar txt
262	if {$txt eq ""} {
263	return -code error "unexpected end of text"
264	}
265
266	set c [string index $txt 0]
267	set txt [string range $txt 1 end]
268	return $c
269	}
270
271	proc tcvJSON::parse {txt} {
272	return [Parse]
273	}
274
275	# Modified from Tcllib's json::_json2dict proc.
276
277	proc tcvJSON::Parse {{txtvar txt}} {
278	upvar 1 $txtvar txt
279
280	set state TOP
281	set current {}
282
283	set txt [string trimleft $txt]
284	while {$txt ne ""} {
285	set c [string index $txt 0]
286
287	# skip whitespace
288	while {[string is space $c]} {
289	getc
290	set c [string index $txt 0]
291	}
292
293	if {$c eq "\{"} {
294	# object
295	switch -- $state {
296	TOP {
297	# This is the toplevel object.
298	getc
299	set state OBJECT
300	set current [create obj]
301	}
302	VALUE {
303	# We are inside an object looking at the value, which is another object.
304	put! -type auto current $name [Parse]
305	set state COMMA
306	}
307	LIST {
308	# We are inside a list and the next element is an object.
309	add! -type auto current [Parse]
310	set state COMMA
311	}
312	default {
313	return -code error "unexpected open brace in $state mode"
314	}
315	}
316	} elseif {$c eq "\}"} {
317	getc
318	if {$state ne "OBJECT" && $state ne "COMMA"} {
319	return -code error "unexpected close brace in $state mode"
320	}
321	return $current
322	} elseif {$c eq ":"} {
323	# name separator
324	getc
325
326	if {$state eq "COLON"} {
327	set state VALUE
328	} else {
329	return -code error "unexpected colon in $state mode"
330	}
331	} elseif {$c eq ","} {
332	# element separator
333	if {$state eq "COMMA"} {
334	getc
335	if {[lindex $current 0] eq "list"} {
336	set state LIST
337	} elseif {[lindex $current 0] eq "obj"} {
338	set state OBJECT
339	}
340	} else {
341	return -code error "unexpected comma in $state mode"
342	}
343	} elseif {$c eq "\""} {
344	# string
345	# capture quoted string with backslash sequences
346	set reStr {(?:(?:\")(?:[^\\\"](?:\\.[^\\\"])*)(?:\"))}
347	set string ""
348	if {![regexp $reStr $txt string]} {
349	set txt [string replace $txt 32 end ...]
350	return -code error "invalid formatted string in $txt"
351	}
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]]
358
359	switch -- $state {
360	TOP {
361	return $string
362	}
363	OBJECT {
364	set name $string
365	set state COLON
366	}
367	LIST {
368	add! -type str current $string
369	set state COMMA
370	}
371	VALUE {
372	put! -type str current $name $string
373	unset name
374	set state COMMA
375	}
376	}
377	} elseif {$c eq "\["} {
378	# JSON array == Tcl list
379	switch -- $state {
380	TOP {
381	getc
382	set current [create list]
383	set state LIST
384	}
385	LIST {
386	add! -type auto current [Parse]
387	set state COMMA
388	}
389	VALUE {
390	put! -type auto current $name [Parse]
391	set state COMMA
392	}
393	default {
394	return -code error "unexpected open bracket in $state mode"
395	}
396	}
397	} elseif {$c eq "\]"} {
398	# end of list
399	getc
400	return $current
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
405	if {$last > 0} {
406	set num [string range $txt 0 [expr {$last - 1}]]
407	set txt [string range $txt $last end]
408
409	switch -- $state {
410	TOP {
411	return $num
412	}
413	LIST {
414	add! -type num current $num
415	set state COMMA
416	}
417	VALUE {
418	put! -type num current $name $num
419	set state COMMA
420	}
421	default {
422	getc
423	return -code error "unexpected number '$c' in $state mode"
424	}
425	}
426	} else {
427	getc
428	return -code error "unexpected '$c' in $state mode"
429	}
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]
434
435	switch -- $state {
436	TOP {
437	return $val
438	}
439	LIST {
440	add! current $val
441	set state COMMA
442	}
443	VALUE {
444	put! current $name $val
445	set state COMMA
446	}
447	default {
448	getc
449	return -code error "unexpected '$c' in $state mode"
450	}
451	}
452	} else {
453	# error, incorrect format or unexpected end of text
454	return -code error "unexpected '$c' in $state mode"
455	}
456	}
457	}
458
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
462	# caller's level.
463
464	proc tcvJSON::objForEach {k v obj script} {
465	if {[lindex $obj 0] ne "obj"} {
466	error "this is not an object"
467	}
468
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]]
472	uplevel $script
473	}
474
475	if {[llength $obj] > 1} {
476	# Clean up after ourselves.
477	uplevel [list unset $k]
478	uplevel [list unset $v]
479	}
480	}
481
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.
486
487	proc tcvJSON::exists? {json thing} {
488	if {[lindex $json 0] eq "obj"} {
489	set increment 2
490	} elseif {[lindex $json 0] eq "list"} {
491	set increment 1
492	} else {
493	error "not a composite type"
494	}
495	for {set i 1} {$i < [llength $json]} {incr i $increment} {
496	if {[lindex $json $i] == $thing} {
497	return 1
498	}
499	}
500	return 0
501	}
502
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
506	# caller's level.
507
508	proc tcvJSON::listForEach {e lst script} {
509	if {[lindex $lst 0] ne "list"} {
510	error "this is not a list"
511	}
512
513	for {set i 1} {$i < [llength $lst]} {incr i} {
514	uplevel [list set $e [lindex $obj $i]]
515	uplevel $script
516	}
517
518	# Don't leave the variables set.
519	uplevel [list unset $e]
520	}