--- /dev/null
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-11-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.tcl: [Bug 3426178]: Fixed bug in "list2json",
+ * json.test: reported by <a11426@users.sourceforge.net>.
+ * json.man: Updated testsuite. Bumped version to 1.1.2.
+ * pkgIndex.tcl:
+
+2011-08-24 Andreas Kupries <andreask@activestate.com>
+
+ * json_write.man:
+ * json_write.test:
+ * json_write.tcl: [Bug 3396787]: Fixed missing argument to call of
+ * pkgIndex.tcl: [info level], breaking the argument checks. Bumped
+ version to 1.0.1
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.tcl (json::parseValue): Fixed a missing -- older 8.4 seems
+ * json.man: to require to handle a dash in $leadingChar. Bumped
+ * pkgIndex.tcl: version to 1.1.1
+
+2009-12-10 Andreas Kupries <andreask@activestate.com>
+
+ * json.tcl: [Patch 2909962]: Accepted rewrite of the json parser
+ * json.man: internals by Thomas Maeder
+ * pkgIndex.tcl: <thomasmaeder@users.sourceforge.net>. The new
+ (regex-based) parser is considerably faster than the previous
+ implementation. Bumped version to 1.1.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-11-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json_write.tcl: New package 'json::write', supporting the
+ * json_write.test: generation of text in JSON format.
+ * json_write.man: Package version 1.
+ * json_write.pcx:
+ * pkgIndex.tcl:
+
+2009-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.tcl: Bumped package to version 1.0.1 due to the bugfix made
+ * pkgIndex.tcl: on 2009-04-18.
+
+2009-05-26 KATO Kanryu <kanryu6@users.sourceforge.net>
+
+ * json.test: improved to compare dicts
+
+2009-04-18 KATO Kanryu <kanryu6@users.sourceforge.net>
+
+ * json.tcl: fixed to parse last integer
+ * json.test: improved to compare dicts
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.pcx: New file. Syntax definitions for the public commands
+ of the json package.
+
+2007-12-05 Andreas Kupries <andreask@activestate.com>
+
+ * json.test: Brought the test results into sync with the ordered
+ dicts of Tcl 8.5. NOTE: This will cause the combination of Tcl
+ 8.4 with a backported dict to fail, at least until either the
+ backported dict does the same ordering, or the tests are split
+ into variants, one for both of the two cases. This fixes [Tcllib
+ SF Bug 1844104], reported by Larry Virden
+ <lvirden@users.sourceforge.net>. Thanks.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-08-25 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * json.test: empty list test cases
+ * json.tcl (json::_json2dict): handle empty list case
+
+2006-08-18 Andreas Kupries <andreask@activestate.com>
+
+ * json.man: Added some more keywords to the docs.
+
+2006-08-17 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * json.tcl, json.man, json.test, pkgIndex.tcl: json package v1.0
+ Parses JSON formatted text into Tcl dicts.
+ See http://www.json.org/ for format details.
--- /dev/null
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin json n 1.1.2]
+[copyright {2006 ActiveState Software Inc.}]
+[copyright {2009 Thomas Maeder, Glue Software Engineering AG}]
+[moddesc {JSON}]
+[titledesc {JSON parser}]
+[category {CGI programming}]
+[require Tcl 8.4]
+[require json [opt 1.1.2]]
+[keywords json javascript {data exchange} {exchange format}]
+[description]
+[para]
+
+The [package json] package provides a simple Tcl-only library for parsing the
+JSON [uri http://www.json.org/] data exchange format as specified in RFC 4627
+[uri http://www.ietf.org/rfc/rfc4627.txt].
+
+There is some ambiguity in parsing JSON because JSON has type information that
+is not maintained by the Tcl conversion. The [package json] package returns
+data as a Tcl [cmd dict]. Either the [package dict] package or Tcl 8.5 is
+required for use.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::json::json2dict] [arg txt]]
+
+Parse JSON formatted text [arg txt] into a Tcl dict and return the value.
+
+[list_end]
+[para]
+
+[section EXAMPLES]
+[para]
+
+An example of a JSON array converted to Tcl. A JSON array is returned as a
+single item with multiple elements.
+
+[para]
+[example {[
+ {
+ "precision": "zip",
+ "Latitude": 37.7668,
+ "Longitude": -122.3959,
+ "Address": "",
+ "City": "SAN FRANCISCO",
+ "State": "CA",
+ "Zip": "94107",
+ "Country": "US"
+ },
+ {
+ "precision": "zip",
+ "Latitude": 37.371991,
+ "Longitude": -122.026020,
+ "Address": "",
+ "City": "SUNNYVALE",
+ "State": "CA",
+ "Zip": "94085",
+ "Country": "US"
+ }
+]
+=>
+{Country US Latitude 37.7668 precision zip State CA City {SAN FRANCISCO} Address {} Zip 94107 Longitude -122.3959} {Country US Latitude 37.371991 precision zip State CA City SUNNYVALE Address {} Zip 94085 Longitude -122.026020}
+}]
+[para]
+
+An example of a JSON object converted to Tcl. A JSON object is returned as a
+multi-element list (a dict).
+
+[para]
+[example {{
+ "Image": {
+ "Width": 800,
+ "Height": 600,
+ "Title": "View from 15th Floor",
+ "Thumbnail": {
+ "Url": "http://www.example.com/image/481989943",
+ "Height": 125,
+ "Width": "100"
+ },
+ "IDs": [116, 943, 234, 38793]
+ }
+}
+=>
+Image {IDs {116 943 234 38793} Thumbnail {Width 100 Height 125 Url http://www.example.com/image/481989943} Width 800 Height 600 Title {View from 15th Floor}}
+}]
+
+[vset CATEGORY json]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
--- /dev/null
+# -*- tcl -*- json.pcx
+# Syntax of the commands provided by package json.
+#
+# For use by TclDevKit's static syntax checker (v4.1+).
+# See http://www.activestate.com/solutions/tcl/
+# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
+# for the specification of the format of the code in this file.
+#
+
+package require pcx
+pcx::register json
+pcx::tcldep 1.0 needs tcl 8.4
+
+namespace eval ::json {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::json::string2json \
+ {checkSimpleArgs 0 -1 {
+ checkWord -- Replace with actual definition --
+ }}
+
+# Initialization via pcx::init.
+# Use a ::json::init procedure for non-standard initialization.
+pcx::complete
--- /dev/null
+#
+# JSON parser for Tcl.
+#
+# See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt
+#
+# Total rework of the code published with version number 1.0 by
+# Thomas Maeder, Glue Software Engineering AG
+#
+# $Id: json.tcl,v 1.7 2011/11/10 21:05:58 andreas_kupries Exp $
+#
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ package require dict
+}
+
+package provide json 1.1.2
+
+namespace eval json {
+ # Regular expression for tokenizing a JSON text (cf. http://json.org/)
+
+ # tokens consisting of a single character
+ variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," }
+ variable singleCharTokenRE "\[[join $singleCharTokens {}]\]"
+
+ # quoted string tokens
+ variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" }
+ variable escapedCharRE "\\\\(?:[join $escapableREs |])"
+ variable unescapedCharRE {[^\\\"]}
+ variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\""
+
+ # (unquoted) words
+ variable wordTokens { "true" "false" "null" }
+ variable wordTokenRE [join $wordTokens "|"]
+
+ # number tokens
+ # negative lookahead (?!0)[[:digit:]]+ might be more elegant, but
+ # would slow down tokenizing by a factor of up to 3!
+ variable positiveRE {[1-9][[:digit:]]*}
+ variable cardinalRE "-?(?:$positiveRE|0)"
+ variable fractionRE {[.][[:digit:]]+}
+ variable exponentialRE {[eE][+-]?[[:digit:]]+}
+ variable numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
+
+ # JSON token
+ variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE"
+
+
+ # 0..n white space characters
+ set whiteSpaceRE {[[:space:]]*}
+
+ # Regular expression for validating a JSON text
+ variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenRE))*${whiteSpaceRE}$"
+}
+
+
+# Validate JSON text
+# @param jsonText JSON text
+# @return 1 iff $jsonText conforms to the JSON grammar
+# (@see http://json.org/)
+proc json::validate {jsonText} {
+ variable validJsonRE
+
+ return [regexp -- $validJsonRE $jsonText]
+}
+
+# Parse JSON text into a dict
+# @param jsonText JSON text
+# @return dict (or list) containing the object represented by $jsonText
+proc json::json2dict {jsonText} {
+ variable tokenRE
+
+ set tokens [regexp -all -inline -- $tokenRE $jsonText]
+ set nrTokens [llength $tokens]
+ set tokenCursor 0
+ return [parseValue $tokens $nrTokens tokenCursor]
+}
+
+# Throw an exception signaling an unexpected token
+proc json::unexpected {tokenCursor token expected} {
+ return -code error "unexpected token \"$token\" at position $tokenCursor; expecting $expected"
+}
+
+# Get rid of the quotes surrounding a string token and substitute the
+# real characters for escape sequences within it
+# @param token
+# @return unquoted unescaped value of the string contained in $token
+proc json::unquoteUnescapeString {token} {
+ set unquoted [string range $token 1 end-1]
+ return [subst -nocommands -novariables $unquoted]
+}
+
+# Parse an object member
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @param objectDictName name (in caller's context) of dict
+# representing the JSON object of which to
+# parse the next member
+proc json::parseObjectMember {tokens nrTokens tokenCursorName objectDictName} {
+ upvar $tokenCursorName tokenCursor
+ upvar $objectDictName objectDict
+
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ set leadingChar [string index $token 0]
+ if {$leadingChar eq "\""} {
+ set memberName [unquoteUnescapeString $token]
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "\":\""
+ } else {
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ if {$token eq ":"} {
+ set memberValue [parseValue $tokens $nrTokens tokenCursor]
+ dict set objectDict $memberName $memberValue
+ } else {
+ unexpected $tokenCursor $token "\":\""
+ }
+ }
+ } else {
+ unexpected $tokenCursor $token "STRING"
+ }
+}
+
+# Parse the members of an object
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @param objectDictName name (in caller's context) of dict
+# representing the JSON object of which to
+# parse the next member
+proc json::parseObjectMembers {tokens nrTokens tokenCursorName objectDictName} {
+ upvar $tokenCursorName tokenCursor
+ upvar $objectDictName objectDict
+
+ while true {
+ parseObjectMember $tokens $nrTokens tokenCursor objectDict
+
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ switch -exact $token {
+ "," {
+ # continue
+ }
+ "\}" {
+ break
+ }
+ default {
+ unexpected $tokenCursor $token "\",\"|\"\}\""
+ }
+ }
+ }
+}
+
+# Parse an object
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @return parsed object (Tcl dict)
+proc json::parseObject {tokens nrTokens tokenCursorName} {
+ upvar $tokenCursorName tokenCursor
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "OBJECT"
+ } else {
+ set result [dict create]
+
+ set token [lindex $tokens $tokenCursor]
+
+ if {$token eq "\}"} {
+ # empty object
+ incr tokenCursor
+ } else {
+ parseObjectMembers $tokens $nrTokens tokenCursor result
+ }
+
+ return $result
+ }
+}
+
+# Parse the elements of an array
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @param resultName name (in caller's context) of the list
+# representing the JSON array
+proc json::parseArrayElements {tokens nrTokens tokenCursorName resultName} {
+ upvar $tokenCursorName tokenCursor
+ upvar $resultName result
+
+ while true {
+ lappend result [parseValue $tokens $nrTokens tokenCursor]
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "\",\"|\"\]\""
+ } else {
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ switch -exact $token {
+ "," {
+ # continue
+ }
+ "\]" {
+ break
+ }
+ default {
+ unexpected $tokenCursor $token "\",\"|\"\]\""
+ }
+ }
+ }
+ }
+}
+
+# Parse an array
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @return parsed array (Tcl list)
+proc json::parseArray {tokens nrTokens tokenCursorName} {
+ upvar $tokenCursorName tokenCursor
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "ARRAY"
+ } else {
+ set result {}
+
+ set token [lindex $tokens $tokenCursor]
+
+ set leadingChar [string index $token 0]
+ if {$leadingChar eq "\]"} {
+ # empty array
+ incr tokenCursor
+ } else {
+ parseArrayElements $tokens $nrTokens tokenCursor result
+ }
+
+ return $result
+ }
+}
+
+# Parse a value
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @return parsed value (dict, list, string, number)
+proc json::parseValue {tokens nrTokens tokenCursorName} {
+ upvar $tokenCursorName tokenCursor
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "VALUE"
+ } else {
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ set leadingChar [string index $token 0]
+ switch -exact -- $leadingChar {
+ "\{" {
+ return [parseObject $tokens $nrTokens tokenCursor]
+ }
+ "\[" {
+ return [parseArray $tokens $nrTokens tokenCursor]
+ }
+ "\"" {
+ # quoted string
+ return [unquoteUnescapeString $token]
+ }
+ "t" -
+ "f" -
+ "n" {
+ # bare word: true, false or null
+ return $token
+ }
+ default {
+ # number?
+ if {[string is double -strict $token]} {
+ return $token
+ } else {
+ unexpected $tokenCursor $token "VALUE"
+ }
+ }
+ }
+ }
+}
+
+proc json::dict2json {dictVal} {
+ # XXX: Currently this API isn't symmetrical, as to create proper
+ # XXX: JSON text requires type knowledge of the input data
+ set json ""
+
+ dict for {key val} $dictVal {
+ # key must always be a string, val may be a number, string or
+ # bare word (true|false|null)
+ if {0 && ![string is double -strict $val]
+ && ![regexp {^(?:true|false|null)$} $val]} {
+ set val "\"$val\""
+ }
+ append json "\"$key\": $val," \n
+ }
+
+ return "\{${json}\}"
+}
+
+proc json::list2json {listVal} {
+ return "\[[join $listVal ,]\]"
+}
+
+proc json::string2json {str} {
+ return "\"$str\""
+}
--- /dev/null
+# json.test - Copyright (C) 2006 ActiveState Software Inc.
+#
+# Tests for the Tcllib json package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: json.test,v 1.8 2011/11/10 21:05:58 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl [expr {[catch {package require dict}] ? "8.5" : "8.4"}]
+testsNeedTcltest 2.0
+
+testing {
+ useLocal json.tcl json
+}
+
+catch {unset JSON}
+catch {unset TCL}
+catch {unset DICTSORT}
+
+proc dictsort3 {spec data} {
+ while [llength $spec] {
+ set type [lindex $spec 0]
+ set spec [lrange $spec 1 end]
+
+ switch -- $type {
+ dict {
+ lappend spec * string
+
+ set json {}
+ foreach {key} [lsort [dict keys $data]] {
+ set val [dict get $data $key]
+ foreach {keymatch valtype} $spec {
+ if {[string match $keymatch $key]} {
+ lappend json $key [dictsort3 $valtype $val]
+ break
+ }
+ }
+ }
+ return $json
+ }
+ list {
+ lappend spec * string
+ set json {}
+ set idx 0
+ foreach {val} $data {
+ foreach {keymatch valtype} $spec {
+ if {$idx == $keymatch || $keymatch eq "*"} {
+ lappend json [dictsort3 $valtype $val]
+ break
+ }
+ }
+ incr idx
+ }
+ return $json
+ }
+ string {
+ return $data
+ }
+ default {error "Invalid type"}
+ }
+ }
+}
+
+
+set JSON(array) {[
+ {
+ "precision": "zip",
+ "Latitude": 37.7668,
+ "Longitude": -122.3959,
+ "Address": "",
+ "City": "SAN FRANCISCO",
+ "State": "CA",
+ "Zip": "94107",
+ "Country": "US"
+ },
+ {
+ "precision": "zip",
+ "Latitude": 37.371991,
+ "Longitude": -122.026020,
+ "Address": "",
+ "City": "SUNNYVALE",
+ "State": "CA",
+ "Zip": "94085",
+ "Country": "US"
+ }
+ ]}
+set TCL(array) {{precision zip Latitude 37.7668 Longitude -122.3959 Address {} City {SAN FRANCISCO} State CA Zip 94107 Country US} {precision zip Latitude 37.371991 Longitude -122.026020 Address {} City SUNNYVALE State CA Zip 94085 Country US}}
+
+set DICTSORT(array) {list dict}
+
+set JSON(glossary) {{
+ "glossary": {
+ "title": "example glossary",
+ "mixlist": ["a \"\" str", -0.09, null, "", {"member":true}],
+ "GlossDiv": {
+ "title": "S",
+ "GlossList": [{
+ "ID": "SGML",
+ "GlossTerm": "Standard \\\" Language",
+ "Acronym": "SGML\\",
+ "Abbrev": "ISO 8879:1986",
+ "GlossDef":
+ "A meta-markup language, used ...",
+ "GlossSeeAlso": ["GML", "XML", "markup"]}]}}
+}}
+set TCL(glossary) {glossary {title {example glossary} mixlist {{a "" str} -0.09 null {} {member true}} GlossDiv {title S GlossList {{ID SGML GlossTerm {Standard \" Language} Acronym SGML\\ Abbrev {ISO 8879:1986} GlossDef {A meta-markup language, used ...} GlossSeeAlso {GML XML markup}}}}}}
+set DICTSORT(glossary) {dict * {dict GlossDiv {dict GlossList {list dict}}}}
+
+set JSON(menu) {{"menu": {
+ "id": "file",
+ "value": "File:",
+ "unival": "\u6021:",
+ "popup": {
+ "menuitem": [
+ {"value": "Open", "onclick": "OpenDoc()"},
+ {"value": "Close", "onclick": "CloseDoc()"}
+ ]
+ }
+}
+}}
+set TCL(menu) [list menu [list id file value File: unival \u6021: popup {menuitem {{value Open onclick OpenDoc()} {value Close onclick CloseDoc()}}}]]
+set DICTSORT(menu) {dict * {dict popup {dict * {list dict}}}}
+
+set JSON(widget) {{"widget": {
+ "debug": "on",
+ "window": {
+ "title":"Sample Widget",
+ "name": "main_window",
+ "width": 500,
+ "height": 500},
+ "text": {
+ "data": "Click Here",
+ "size": 36,
+ "style": "bold",
+ "name": null,
+ "hOffset":250,
+ "vOffset": 100,
+ "alignment": "center",
+ "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;"
+ }
+}
+}}
+set TCL(widget) {widget {debug on window {title {Sample Widget} name main_window width 500 height 500} text {data {Click Here} size 36 style bold name null hOffset 250 vOffset 100 alignment center onMouseUp {sun1.opacity = (sun1.opacity / 100) * 90;}}}}
+set DICTSORT(widget) {dict * {dict text dict window dict}}
+
+set JSON(menu2) {{"menu": {
+ "header": "Viewer",
+ "items": [
+ {"id": "Open"},
+ {"id": "OpenNew", "label": "Open New"},
+ null,
+ {"id": "ZoomIn", "label": "Zoom In"},
+ {"id": "ZoomOut", "label": "Zoom Out"},
+ null,
+ {"id": "Help"},
+ {"id": "About", "label": "About Viewer..."}
+ ]
+}
+}}
+set TCL(menu2) {menu {header Viewer items {{id Open} {id OpenNew label {Open New}} null {id ZoomIn label {Zoom In}} {id ZoomOut label {Zoom Out}} null {id Help} {id About label {About Viewer...}}}}}
+set DICTSORT(menu2) {dict * {dict items {list 0 dict 1 dict 3 dict 4 dict 6 dict 7 dict}}}
+
+set JSON(emptyList) {[]}
+set TCL(emptyList) {}
+
+set JSON(emptyList2) {{"menu": []}}
+set TCL(emptyList2) {menu {}}
+
+set JSON(emptyList3) {["menu", []]}
+set TCL(emptyList3) {menu {}}
+
+set JSON(emptyList4) {[[]]}
+set TCL(emptyList4) {{}}
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+set i 0
+foreach name [array names JSON] {
+ test json-1.[incr i] "test JSON $name" -body {
+ set res [json::json2dict $JSON($name)]
+ if {[info exists DICTSORT($name)]} {
+ return [string equal [dictsort3 $DICTSORT($name) $res] [dictsort3 $DICTSORT($name) $TCL($name)]]
+ } else {
+ return [string equal $res $TCL($name)]
+ }
+ } -result 1
+}
+
+# -------------------------------------------------------------------------
+# More Tests
+# -------------------------------------------------------------------------
+
+test json-2.0 {list2json} -body {
+ json::list2json {{"a"} {"b"} {"c"}}
+} -result {["a","b","c"]}
+
+test json-2.1 {string2json} -body {
+ json::string2json a
+} -result {"a"}
+
+# -------------------------------------------------------------------------
+catch {unset JSON}
+catch {unset TCL}
+catch {unset DICTSORT}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin json::write n 1.0.1]
+[copyright {2009-2011 Andreas Kupries <andreas_kupries@sourceforge.net>}]
+[moddesc {JSON}]
+[titledesc {JSON generation}]
+[category {CGI programming}]
+[require Tcl 8.5]
+[require json::write [opt 1.0.1]]
+[keywords json javascript {data exchange} {exchange format}]
+[description]
+[para]
+
+The [package json::write] package provides a simple Tcl-only library
+for generation of text in the JSON [uri http://www.json.org/] data
+exchange format as specified in
+RFC 4627 [uri http://www.ietf.org/rfc/rfc4627.txt].
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::json::write] [method indented]]
+
+This method returns the current state of the indentation setting.
+
+
+[call [cmd ::json::write] [method indented] [arg flag]]
+
+This and the method [method aligned] configure the layout of the JSON
+generated by the package.
+
+[para]
+
+If this [arg flag] is set (default) the package will break the
+generated JSON code across lines and indent it according to its inner
+structure, with each key of an object on a separate line.
+
+[para]
+
+If this flag is not set, the whole JSON object will be written on a
+single line, with minimum spacing between all elements.
+
+
+[call [cmd ::json::write] [method aligned]]
+
+This method returns the current state of the alignment setting.
+
+
+[call [cmd ::json::write] [method aligned] [arg flag]]
+
+
+This and the method [method indented] configure the layout of the JSON
+generated by the package.
+
+[para]
+
+If this [arg flag] is set (default) the package ensures that the
+values for the keys in an object are vertically aligned with each
+other, for a nice table effect. To make this work this also implies
+that [var indented] is set as well.
+
+[para]
+
+If this flag is not set, the output is formatted as per the value of
+[var indented], without trying to align the values for object keys.
+
+
+[call [cmd ::json::write] [method string] [arg s]]
+
+This method takes the string [arg s] and returns it properly quoted
+for JSON as its result.
+
+
+[call [cmd ::json::write] [method array] [arg arg]...]
+
+This method takes a series of JSON formatted arguments and returns
+them as a properly formatted JSON array as its result.
+
+
+[call [cmd ::json::write] [method object] [arg key] [arg value]...]
+
+This method takes a series of key/value arguments, the values already
+formatted for JSON, and returns them as a properly formatted JSON
+object as its result, with the keys formatted as JSON strings.
+
+
+[list_end]
+[para]
+
+[vset CATEGORY json]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
--- /dev/null
+# -*- tcl -*- json_write.pcx
+# Syntax of the commands provided by package json::write.
+#
+# For use by TclDevKit's static syntax checker (v4.1+).
+# See http://www.activestate.com/solutions/tcl/
+# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
+# for the specification of the format of the code in this file.
+#
+
+package require pcx
+pcx::register json::write
+pcx::tcldep 1.0 needs tcl 8.5
+
+namespace eval ::json::write {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::json::write {checkSimpleArgs 1 -1 {
+ {checkOption {
+ {indented {checkSimpleArgs 0 1 {
+ checkBoolean
+ }}}
+ {aligned {checkSimpleArgs 0 1 {
+ checkBoolean
+ }}}
+ {string {checkSimpleArgs 1 1 {
+ checkWord
+ }}}
+ {array {checkSimpleArgs 0 -1 {
+ checkWord
+ }}}
+ {object {checkSimpleArgsModNk 0 2 {
+ checkWord
+ checkWord
+ }}}}
+ } {}}
+}
+
+# Initialization via pcx::init.
+# Use a ::json::write::init procedure for non-standard initialization.
+pcx::complete
--- /dev/null
+# json_write.tcl --
+#
+# Commands for the generation of JSON (Java Script Object Notation).
+#
+# Copyright (c) 2009-2011 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: json_write.tcl,v 1.2 2011/08/24 20:09:44 andreas_kupries Exp $
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+
+namespace eval ::json::write {
+ namespace export \
+ string array object indented aligned
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::json::write::indented {{bool {}}} {
+ variable indented
+
+ if {[llength [info level 0]] > 2} {
+ return -code error {wrong # args: should be "json::write indented ?bool?"}
+ } elseif {[llength [info level 0]] == 2} {
+ if {![::string is boolean -strict $bool]} {
+ return -code error "Expected boolean, got \"$bool\""
+ }
+ set indented $bool
+ if {!$indented} {
+ variable aligned 0
+ }
+ }
+
+ return $indented
+}
+
+proc ::json::write::aligned {{bool {}}} {
+ variable aligned
+
+ if {[llength [info level 0]] > 2} {
+ return -code error {wrong # args: should be "json::write aligned ?bool?"}
+ } elseif {[llength [info level 0]] == 2} {
+ if {![::string is boolean -strict $bool]} {
+ return -code error "Expected boolean, got \"$bool\""
+ }
+ set aligned $bool
+ if {$aligned} {
+ variable indented 1
+ }
+ }
+
+ return $aligned
+}
+
+proc ::json::write::string {s} {
+ variable quotes
+ return "\"[::string map $quotes $s]\""
+}
+
+proc ::json::write::array {args} {
+ # always compact form.
+ return "\[[join $args ,]\]"
+}
+
+proc ::json::write::object {args} {
+ # The dict in args maps string keys to json-formatted data. I.e.
+ # we have to quote the keys, but not the values, as the latter are
+ # already in the proper format.
+
+ variable aligned
+ variable indented
+
+ if {[llength $args] %2 == 1} {
+ return -code error {wrong # args, expected an even number of arguments}
+ }
+
+ set dict {}
+ foreach {k v} $args {
+ lappend dict [string $k] $v
+ }
+
+ if {$aligned} {
+ set max [MaxKeyLength $dict]
+ }
+
+ if {$indented} {
+ set content {}
+ foreach {k v} $dict {
+ if {$aligned} {
+ set k [AlignLeft $max $k]
+ }
+ if {[::string match *\n* $v]} {
+ # multi-line value
+ lappend content " $k : [Indent $v { } 1]"
+ } else {
+ # single line value.
+ lappend content " $k : $v"
+ }
+ }
+ if {[llength $content]} {
+ return "\{\n[join $content ,\n]\n\}"
+ } else {
+ return "\{\}"
+ }
+ } else {
+ # ultra compact form.
+ set tmp {}
+ foreach {k v} $dict {
+ lappend tmp "$k:$v"
+ }
+ return "\{[join $tmp ,]\}"
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Internals.
+
+proc ::json::write::Indent {text prefix skip} {
+ set pfx ""
+ set result {}
+ foreach line [split $text \n] {
+ if {!$skip} { set pfx $prefix } else { incr skip -1 }
+ lappend result ${pfx}$line
+ }
+ return [join $result \n]
+}
+
+proc ::json::write::MaxKeyLength {dict} {
+ # Find the max length of the keys in the dictionary.
+
+ set lengths 0 ; # This will be the max if the dict is empty, and
+ # prevents the mathfunc from throwing errors for
+ # that case.
+
+ foreach str [dict keys $dict] {
+ lappend lengths [::string length $str]
+ }
+
+ return [tcl::mathfunc::max {*}$lengths]
+}
+
+proc ::json::write::AlignLeft {fieldlen str} {
+ return [format %-${fieldlen}s $str]
+ #return $str[::string repeat { } [expr {$fieldlen - [::string length $str]}]]
+}
+
+# ### ### ### ######### ######### #########
+
+namespace eval ::json::write {
+ # Configuration of the layout to write.
+
+ # indented = boolean. objects are indented.
+ # aligned = boolean. object keys are aligned vertically.
+
+ # aligned => indented.
+
+ # Combinations of the format specific entries
+ # I A |
+ # - - + ---------------------
+ # 0 0 | Ultracompact (no whitespace, single line)
+ # 1 0 | Indented
+ # 0 1 | Not possible, per the implications above.
+ # 1 1 | Indented + vertically aligned keys
+ # - - + ---------------------
+
+ variable indented 1
+ variable aligned 1
+
+ variable quotes \
+ [list "\"" "\\\"" / \\/ \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide json::write 1.0.1
+return
--- /dev/null
+# json_write.test - Copyright (C) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# Tests for the Tcllib json::write package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: json_write.test,v 1.1 2009/11/25 04:41:01 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+testing {
+ useLocal json_write.tcl json::write
+}
+
+# -------------------------------------------------------------------------
+
+set data {grammar {
+ rules {
+ A {is {/ {t +} {t -}} mode value}
+ D {is {/ {t 0} {t 1} } mode value}
+ E {is {/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}} mode value}
+ F {is {x {n T} {* {x {n A} {n T}}}} mode value}
+ M {is {/ {t *} {t /}} mode value}
+ N {is {x {? {n S}} {+ {n D}}} mode value}
+ S {is {/ {t +} {t -}} mode value}
+ T {is {n N} mode value}
+ }
+ start {n Expression}
+}}
+
+proc gen {serial} {
+ array set g $serial
+ array set g $g(grammar)
+ unset g(grammar)
+
+ # Assemble the rules ...
+ set rules {}
+ foreach {symbol def} $g(rules) {
+ lassign $def _ is _ mode
+ lappend rules $symbol \
+ [json::write object \
+ is [json::write string $is] \
+ mode [json::write string $mode]]
+ }
+
+ # Assemble the final result ...
+ return [json::write object grammar \
+ [json::write object \
+ rules [json::write object {*}$rules] \
+ start [json::write string $g(start)]]]
+}
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+test json-write-1.0 {default configuration} -body {
+ list [json::write indented] [json::write aligned]
+} -result {1 1}
+
+test json-write-1.1 {implied configurations} -body {
+ json::write indented 0
+ list [json::write indented] [json::write aligned]
+} -result {0 0}
+
+test json-write-1.2 {implied configurations} -body {
+ json::write indented 0
+ json::write aligned 0
+ json::write aligned 1
+ list [json::write indented] [json::write aligned]
+} -result {1 1}
+
+# -------------------------------------------------------------------------
+
+test json-write-2.0 {argument errors} -body {
+ json::write indented X Y
+} -returnCodes 1 -result {wrong # args: should be "json::write indented ?bool?"}
+
+test json-write-2.1 {argument errors} -body {
+ json::write aligned X Y
+} -returnCodes 1 -result {wrong # args: should be "json::write aligned ?bool?"}
+
+test json-write-2.2 {argument errors} -body {
+ json::write string
+} -returnCodes 1 -result {wrong # args: should be "json::write string s"}
+
+test json-write-2.3 {argument errors} -body {
+ json::write string A B
+} -returnCodes 1 -result {wrong # args: should be "json::write string s"}
+
+test json-write-2.4 {argument errors} -body {
+ json::write object A
+} -returnCodes 1 -result {wrong # args, expected an even number of arguments}
+
+# -------------------------------------------------------------------------
+
+test json-write-3.0 {indented, aligned} -body {
+ json::write indented 1
+ json::write aligned 1
+ gen $data
+} -result {{
+ "grammar" : {
+ "rules" : {
+ "A" : {
+ "is" : "\/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "D" : {
+ "is" : "\/ {t 0} {t 1} ",
+ "mode" : "value"
+ },
+ "E" : {
+ "is" : "\/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}",
+ "mode" : "value"
+ },
+ "F" : {
+ "is" : "x {n T} {* {x {n A} {n T}}}",
+ "mode" : "value"
+ },
+ "M" : {
+ "is" : "\/ {t *} {t \/}",
+ "mode" : "value"
+ },
+ "N" : {
+ "is" : "x {? {n S}} {+ {n D}}",
+ "mode" : "value"
+ },
+ "S" : {
+ "is" : "\/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "T" : {
+ "is" : "n N",
+ "mode" : "value"
+ }
+ },
+ "start" : "n Expression"
+ }
+}}
+
+test json-write-3.1 {indented, !aligned} -body {
+ json::write indented 1
+ json::write aligned 0
+ gen $data
+} -result {{
+ "grammar" : {
+ "rules" : {
+ "A" : {
+ "is" : "\/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "D" : {
+ "is" : "\/ {t 0} {t 1} ",
+ "mode" : "value"
+ },
+ "E" : {
+ "is" : "\/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}",
+ "mode" : "value"
+ },
+ "F" : {
+ "is" : "x {n T} {* {x {n A} {n T}}}",
+ "mode" : "value"
+ },
+ "M" : {
+ "is" : "\/ {t *} {t \/}",
+ "mode" : "value"
+ },
+ "N" : {
+ "is" : "x {? {n S}} {+ {n D}}",
+ "mode" : "value"
+ },
+ "S" : {
+ "is" : "\/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "T" : {
+ "is" : "n N",
+ "mode" : "value"
+ }
+ },
+ "start" : "n Expression"
+ }
+}}
+
+test json-write-3.1 {!indented, !aligned} -body {
+ json::write indented 0
+ json::write aligned 0
+ gen $data
+} -result {{"grammar":{"rules":{"A":{"is":"\/ {t +} {t -}","mode":"value"},"D":{"is":"\/ {t 0} {t 1} ","mode":"value"},"E":{"is":"\/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}","mode":"value"},"F":{"is":"x {n T} {* {x {n A} {n T}}}","mode":"value"},"M":{"is":"\/ {t *} {t \/}","mode":"value"},"N":{"is":"x {? {n S}} {+ {n D}}","mode":"value"},"S":{"is":"\/ {t +} {t -}","mode":"value"},"T":{"is":"n N","mode":"value"}},"start":"n Expression"}}}
+
+# -------------------------------------------------------------------------
+unset data
+rename gen {}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded json 1.1.2 [list source [file join $dir json.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded json::write 1.0.1 [list source [file join $dir json_write.tcl]]
projects / scpubgit/TenDotTcl.git / commitdiff