Attachment "json.tcl" to
ticket [2967134fff]
added by
cwjolly
2010-03-10 10:38:29.
#
# 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.13 2009/12/10 08:45:17 maeder Exp $
#
if {$::tcl_version < 8.5} {
package require dict
}
package provide json 1.0
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"
variable quotevalues false;
variable indexlists false;
# 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 {indexLists false} {quoteValues false } } {
variable tokenRE
variable indexlists $indexLists
variable quotevalues $quoteValues
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} {
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=="\""} {
set memberName [unquoteUnescapeString $token]
if {$tokenCursor==$nrTokens} {
unexpected $tokenCursor "END" "\":\""
} else {
set token [lindex $tokens $tokenCursor]
incr tokenCursor
if {$token==":"} {
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=="\}"} {
# 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} {
variable indexlists
upvar $tokenCursorName tokenCursor
upvar $resultName result
set lcount -1
while true {
if { $indexlists } {
lappend result [incr lcount] [parseValue $tokens $nrTokens tokenCursor]
} else {
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=="\]"} {
# 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} {
variable quotevalues
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
if { $quotevalues } {
return \"[unquoteUnescapeString $token]\"
} else {
return \"[unquoteUnescapeString $token]\"
}
}
"t" -
"f" -
"n" {
# bare word: true, false or null
if { $quotevalues } {
return \"$token\"
} else {
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\""
}
