# # 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 } # Parse JSON text into a dict # @param jsonText JSON text # @return dict (or list) containing the object represented by $jsonText proc ::json::json2dict_tcl {jsonText} { variable tokenRE set tokens [regexp -all -inline -- $tokenRE $jsonText] set nrTokens [llength $tokens] set tokenCursor 0 #puts T:\t[join $tokens \nT:\t] return [parseValue $tokens $nrTokens tokenCursor] } # Parse multiple JSON entities in a string into a list of dictionaries # @param jsonText JSON text to parse # @param max Max number of entities to extract. # @return list of (dict (or list) containing the objects) represented by $jsonText proc ::json::many-json2dict_tcl {jsonText {max -1}} { variable tokenRE if {$max == 0} { return -code error -errorCode {JSON BAD-LIMIT ZERO} \ "Bad limit 0 of json entities to extract." } set tokens [regexp -all -inline -- $tokenRE $jsonText] set nrTokens [llength $tokens] set tokenCursor 0 set result {} set found 0 set n $max while {$n != 0} { if {$tokenCursor >= $nrTokens} break lappend result [parseValue $tokens $nrTokens tokenCursor] incr found if {$n > 0} {incr n -1} } if {$n > 0} { return -code error -errorCode {JSON BAD-LIMIT TOO LARGE} \ "Bad limit $max of json entities to extract, found only $found." } return $result } # Throw an exception signaling an unexpected token proc ::json::unexpected {tokenCursor token expected} { return -code error -errorcode [list JSON UNEXPECTED $tokenCursor $expected] \ "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 {tokenCursor token} { variable stringREv set unquoted [string range $token 1 end-1] if {![regexp $stringREv $token]} { unexpected $tokenCursor $token STRING } set res [subst -nocommands -novariables $unquoted] return $res } # 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] set tc $tokenCursor incr tokenCursor set leadingChar [string index $token 0] if {$leadingChar eq "\""} { set memberName [unquoteUnescapeString $tc $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] set tc $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 $tc $token] } "t" - "f" - "n" { # bare word: true, false, null (return as is) return $token } default { # number? if {[string is double -strict $token]} { return $token } else { unexpected $tokenCursor $token "VALUE" } } } } }