json/json.tcl

   1 #
   2 #   JSON parser for Tcl.
   3 #
   4 #   See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt
   5 #
   6 #   Total rework of the code published with version number 1.0 by
   7 #   Thomas Maeder, Glue Software Engineering AG
   8 #
   9 #   $Id: json.tcl,v 1.7 2011/11/10 21:05:58 andreas_kupries Exp $
  10 #
  11
  12 if {![package vsatisfies [package provide Tcl] 8.5]} {
  13     package require dict
  14 }
  15
  16 package provide json 1.1.2
  17
  18 namespace eval json {
  19     # Regular expression for tokenizing a JSON text (cf. http://json.org/)
  20
  21     # tokens consisting of a single character
  22     variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," }
  23     variable singleCharTokenRE "\[[join $singleCharTokens {}]\]"
  24
  25     # quoted string tokens
  26     variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" }
  27     variable escapedCharRE "\\\\(?:[join $escapableREs |])"
  28     variable unescapedCharRE {[^\\\"]}
  29     variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\""
  30
  31     # (unquoted) words
  32     variable wordTokens { "true" "false" "null" }
  33     variable wordTokenRE [join $wordTokens "|"]
  34
  35     # number tokens
  36     # negative lookahead (?!0)[[:digit:]]+ might be more elegant, but
  37     # would slow down tokenizing by a factor of up to 3!
  38     variable positiveRE {[1-9][[:digit:]]*}
  39     variable cardinalRE "-?(?:$positiveRE|0)"
  40     variable fractionRE {[.][[:digit:]]+}
  41     variable exponentialRE {[eE][+-]?[[:digit:]]+}
  42     variable numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
  43
  44     # JSON token
  45     variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE"
  46
  47
  48     # 0..n white space characters
  49     set whiteSpaceRE {[[:space:]]*}
  50
  51     # Regular expression for validating a JSON text
  52     variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenRE))*${whiteSpaceRE}$"
  53 }
  54
  55
  56 # Validate JSON text
  57 # @param jsonText JSON text
  58 # @return 1 iff $jsonText conforms to the JSON grammar
  59 #           (@see http://json.org/)
  60 proc json::validate {jsonText} {
  61     variable validJsonRE
  62
  63     return [regexp -- $validJsonRE $jsonText]
  64 }
  65
  66 # Parse JSON text into a dict
  67 # @param jsonText JSON text
  68 # @return dict (or list) containing the object represented by $jsonText
  69 proc json::json2dict {jsonText} {
  70     variable tokenRE
  71
  72     set tokens [regexp -all -inline -- $tokenRE $jsonText]
  73     set nrTokens [llength $tokens]
  74     set tokenCursor 0
  75     return [parseValue $tokens $nrTokens tokenCursor]
  76 }
  77
  78 # Throw an exception signaling an unexpected token
  79 proc json::unexpected {tokenCursor token expected} {
  80      return -code error "unexpected token \"$token\" at position $tokenCursor; expecting $expected"
  81 }
  82
  83 # Get rid of the quotes surrounding a string token and substitute the
  84 # real characters for escape sequences within it
  85 # @param token
  86 # @return unquoted unescaped value of the string contained in $token
  87 proc json::unquoteUnescapeString {token} {
  88     set unquoted [string range $token 1 end-1]
  89     return [subst -nocommands -novariables $unquoted]
  90 }
  91
  92 # Parse an object member
  93 # @param tokens list of tokens
  94 # @param nrTokens length of $tokens
  95 # @param tokenCursorName name (in caller's context) of variable
  96 #                        holding current position in $tokens
  97 # @param objectDictName name (in caller's context) of dict
  98 #                       representing the JSON object of which to
  99 #                       parse the next member
 100 proc json::parseObjectMember {tokens nrTokens tokenCursorName objectDictName} {
 101     upvar $tokenCursorName tokenCursor
 102     upvar $objectDictName objectDict
 103
 104     set token [lindex $tokens $tokenCursor]
 105     incr tokenCursor
 106
 107     set leadingChar [string index $token 0]
 108     if {$leadingChar eq "\""} {
 109         set memberName [unquoteUnescapeString $token]
 110
 111         if {$tokenCursor == $nrTokens} {
 112             unexpected $tokenCursor "END" "\":\""
 113         } else {
 114             set token [lindex $tokens $tokenCursor]
 115             incr tokenCursor
 116
 117             if {$token eq ":"} {
 118                 set memberValue [parseValue $tokens $nrTokens tokenCursor]
 119                 dict set objectDict $memberName $memberValue
 120             } else {
 121                 unexpected $tokenCursor $token "\":\""
 122             }
 123         }
 124     } else {
 125         unexpected $tokenCursor $token "STRING"
 126     }
 127 }
 128
 129 # Parse the members of an object
 130 # @param tokens list of tokens
 131 # @param nrTokens length of $tokens
 132 # @param tokenCursorName name (in caller's context) of variable
 133 #                        holding current position in $tokens
 134 # @param objectDictName name (in caller's context) of dict
 135 #                       representing the JSON object of which to
 136 #                       parse the next member
 137 proc json::parseObjectMembers {tokens nrTokens tokenCursorName objectDictName} {
 138     upvar $tokenCursorName tokenCursor
 139     upvar $objectDictName objectDict
 140
 141     while true {
 142         parseObjectMember $tokens $nrTokens tokenCursor objectDict
 143
 144         set token [lindex $tokens $tokenCursor]
 145         incr tokenCursor
 146
 147         switch -exact $token {
 148             "," {
 149                 # continue
 150             }
 151             "\}" {
 152                 break
 153             }
 154             default {
 155                 unexpected $tokenCursor $token "\",\"|\"\}\""
 156             }
 157         }
 158     }
 159 }
 160
 161 # Parse an object
 162 # @param tokens list of tokens
 163 # @param nrTokens length of $tokens
 164 # @param tokenCursorName name (in caller's context) of variable
 165 #                        holding current position in $tokens
 166 # @return parsed object (Tcl dict)
 167 proc json::parseObject {tokens nrTokens tokenCursorName} {
 168     upvar $tokenCursorName tokenCursor
 169
 170     if {$tokenCursor == $nrTokens} {
 171         unexpected $tokenCursor "END" "OBJECT"
 172     } else {
 173         set result [dict create]
 174
 175         set token [lindex $tokens $tokenCursor]
 176
 177         if {$token eq "\}"} {
 178             # empty object
 179             incr tokenCursor
 180         } else {
 181             parseObjectMembers $tokens $nrTokens tokenCursor result
 182         }
 183
 184         return $result
 185     }
 186 }
 187
 188 # Parse the elements of an array
 189 # @param tokens list of tokens
 190 # @param nrTokens length of $tokens
 191 # @param tokenCursorName name (in caller's context) of variable
 192 #                        holding current position in $tokens
 193 # @param resultName name (in caller's context) of the list
 194 #                   representing the JSON array
 195 proc json::parseArrayElements {tokens nrTokens tokenCursorName resultName} {
 196     upvar $tokenCursorName tokenCursor
 197     upvar $resultName result
 198
 199     while true {
 200         lappend result [parseValue $tokens $nrTokens tokenCursor]
 201
 202         if {$tokenCursor == $nrTokens} {
 203             unexpected $tokenCursor "END" "\",\"|\"\]\""
 204         } else {
 205             set token [lindex $tokens $tokenCursor]
 206             incr tokenCursor
 207
 208             switch -exact $token {
 209                 "," {
 210                     # continue
 211                 }
 212                 "\]" {
 213                     break
 214                 }
 215                 default {
 216                     unexpected $tokenCursor $token "\",\"|\"\]\""
 217                 }
 218             }
 219         }
 220     }
 221 }
 222
 223 # Parse an array
 224 # @param tokens list of tokens
 225 # @param nrTokens length of $tokens
 226 # @param tokenCursorName name (in caller's context) of variable
 227 #                        holding current position in $tokens
 228 # @return parsed array (Tcl list)
 229 proc json::parseArray {tokens nrTokens tokenCursorName} {
 230     upvar $tokenCursorName tokenCursor
 231
 232     if {$tokenCursor == $nrTokens} {
 233         unexpected $tokenCursor "END" "ARRAY"
 234     } else {
 235         set result {}
 236
 237         set token [lindex $tokens $tokenCursor]
 238
 239         set leadingChar [string index $token 0]
 240         if {$leadingChar eq "\]"} {
 241             # empty array
 242             incr tokenCursor
 243         } else {
 244             parseArrayElements $tokens $nrTokens tokenCursor result
 245         }
 246
 247         return $result
 248     }
 249 }
 250
 251 # Parse a value
 252 # @param tokens list of tokens
 253 # @param nrTokens length of $tokens
 254 # @param tokenCursorName name (in caller's context) of variable
 255 #                        holding current position in $tokens
 256 # @return parsed value (dict, list, string, number)
 257 proc json::parseValue {tokens nrTokens tokenCursorName} {
 258     upvar $tokenCursorName tokenCursor
 259
 260     if {$tokenCursor == $nrTokens} {
 261         unexpected $tokenCursor "END" "VALUE"
 262     } else {
 263         set token [lindex $tokens $tokenCursor]
 264         incr tokenCursor
 265
 266         set leadingChar [string index $token 0]
 267         switch -exact -- $leadingChar {
 268             "\{" {
 269                 return [parseObject $tokens $nrTokens tokenCursor]
 270             }
 271             "\[" {
 272                 return [parseArray $tokens $nrTokens tokenCursor]
 273             }
 274             "\"" {
 275                 # quoted string
 276                 return [unquoteUnescapeString $token]
 277             }
 278             "t" -
 279             "f" -
 280             "n" {
 281                 # bare word: true, false or null
 282                 return $token
 283             }
 284             default {
 285                 # number?
 286                 if {[string is double -strict $token]} {
 287                     return $token
 288                 } else {
 289                     unexpected $tokenCursor $token "VALUE"
 290                 }
 291             }
 292         }
 293     }
 294 }
 295
 296 proc json::dict2json {dictVal} {
 297     # XXX: Currently this API isn't symmetrical, as to create proper
 298     # XXX: JSON text requires type knowledge of the input data
 299     set json ""
 300
 301     dict for {key val} $dictVal {
 302         # key must always be a string, val may be a number, string or
 303         # bare word (true|false|null)
 304         if {0 && ![string is double -strict $val]
 305             && ![regexp {^(?:true|false|null)$} $val]} {
 306             set val "\"$val\""
 307         }
 308         append json "\"$key\": $val," \n
 309     }
 310
 311     return "\{${json}\}"
 312 }
 313
 314 proc json::list2json {listVal} {
 315     return "\[[join $listVal ,]\]"
 316 }
 317
 318 proc json::string2json {str} {
 319     return "\"$str\""
 320 }