From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 17 Jun 2012 23:08:34 +0000 (+0100)
Subject: import tcvJSON.tcl
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=867f23e8e79c53bdf7885f3588f2fdff6d6bb315;p=scpubgit%2FTenDotTcl.git

import tcvJSON.tcl
---

diff --git a/tcvJSON.tcl b/tcvJSON.tcl
new file mode 100755
index 0000000..a0edff4
--- /dev/null
+++ b/tcvJSON.tcl
@@ -0,0 +1,520 @@
+######################################################################
+###                                                                ###
+###  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]
+}