[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
    set nl "\n"

    if {[llength $args] > 0} {
        set indent [lindex $args 0]
        if {[llength $args] > 1} {
          set indentIncr [lindex $args 1]
        } else {
          set indentIncr $indent
        }
        if {$indent == 0} { set nl "" }
    }

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

        {obj} {
            append output "\{$nl[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}] $indentIncr]"
            }
            append output [join $tmp ",\n[string repeat " " $indent]"]
            append output "$nl[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
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 {}
867f23e8	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]"]
1e0b6d5f	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	}
867f23e8	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	}