From: Matt S Trout Date: Sat, 8 Sep 2012 16:56:22 +0000 (+0000) Subject: import json package X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=458402ad7848042949e49d5b73831f75a870317c;p=scpubgit%2FTenDotTcl.git import json package --- diff --git a/json/ChangeLog b/json/ChangeLog new file mode 100644 index 0000000..e6195e0 --- /dev/null +++ b/json/ChangeLog @@ -0,0 +1,127 @@ +2011-12-13 Andreas Kupries + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-11-10 Andreas Kupries + + * json.tcl: [Bug 3426178]: Fixed bug in "list2json", + * json.test: reported by . + * json.man: Updated testsuite. Bumped version to 1.1.2. + * pkgIndex.tcl: + +2011-08-24 Andreas Kupries + + * 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 + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2011-01-20 Andreas Kupries + + * 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 + + * json.tcl: [Patch 2909962]: Accepted rewrite of the json parser + * json.man: internals by Thomas Maeder + * pkgIndex.tcl: . The new + (regex-based) parser is considerably faster than the previous + implementation. Bumped version to 1.1. + +2009-12-07 Andreas Kupries + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-11-24 Andreas Kupries + + * 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 + + * 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 + + * json.test: improved to compare dicts + +2009-04-18 KATO Kanryu + + * json.tcl: fixed to parse last integer + * json.test: improved to compare dicts + +2008-12-12 Andreas Kupries + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-10-16 Andreas Kupries + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-06-14 Andreas Kupries + + * json.pcx: New file. Syntax definitions for the public commands + of the json package. + +2007-12-05 Andreas Kupries + + * 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 + . Thanks. + +2007-09-12 Andreas Kupries + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-03-21 Andreas Kupries + + * 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 + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-08-25 Jeff Hobbs + + * json.test: empty list test cases + * json.tcl (json::_json2dict): handle empty list case + +2006-08-18 Andreas Kupries + + * json.man: Added some more keywords to the docs. + +2006-08-17 Jeff Hobbs + + * 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. diff --git a/json/json.man b/json/json.man new file mode 100644 index 0000000..d6e79bb --- /dev/null +++ b/json/json.man @@ -0,0 +1,91 @@ +[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] diff --git a/json/json.pcx b/json/json.pcx new file mode 100644 index 0000000..0f4521c --- /dev/null +++ b/json/json.pcx @@ -0,0 +1,26 @@ +# -*- 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 + +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 diff --git a/json/json.tcl b/json/json.tcl new file mode 100644 index 0000000..9f55805 --- /dev/null +++ b/json/json.tcl @@ -0,0 +1,320 @@ +# +# 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\"" +} diff --git a/json/json.test b/json/json.test new file mode 100644 index 0000000..05fad36 --- /dev/null +++ b/json/json.test @@ -0,0 +1,220 @@ +# 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: diff --git a/json/json_write.man b/json/json_write.man new file mode 100644 index 0000000..8231582 --- /dev/null +++ b/json/json_write.man @@ -0,0 +1,92 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin json::write n 1.0.1] +[copyright {2009-2011 Andreas Kupries }] +[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] diff --git a/json/json_write.pcx b/json/json_write.pcx new file mode 100644 index 0000000..b24956a --- /dev/null +++ b/json/json_write.pcx @@ -0,0 +1,42 @@ +# -*- 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 + +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 diff --git a/json/json_write.tcl b/json/json_write.tcl new file mode 100644 index 0000000..7310172 --- /dev/null +++ b/json/json_write.tcl @@ -0,0 +1,185 @@ +# json_write.tcl -- +# +# Commands for the generation of JSON (Java Script Object Notation). +# +# Copyright (c) 2009-2011 Andreas Kupries +# +# 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 diff --git a/json/json_write.test b/json/json_write.test new file mode 100644 index 0000000..a95a265 --- /dev/null +++ b/json/json_write.test @@ -0,0 +1,208 @@ +# json_write.test - Copyright (C) 2009 Andreas Kupries +# +# 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: diff --git a/json/pkgIndex.tcl b/json/pkgIndex.tcl new file mode 100644 index 0000000..3ff8dec --- /dev/null +++ b/json/pkgIndex.tcl @@ -0,0 +1,7 @@ +# 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]]