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.5 2009/12/10 17:48:12 andreas_kupries Exp $ 10# 11 12if {![package vsatisfies [package provide Tcl] 8.5]} { 13 package require dict 14} 15 16package provide json 1.1 17 18namespace 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/) 60proc 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 69proc 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 79proc 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 87proc 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 100proc 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 137proc 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) 167proc 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 195proc 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) 229proc 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) 257proc 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 296proc 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 314proc json::list2json {listVal} { 315 return "\[$[join $listVal ,]\]" 316} 317 318proc json::string2json {str} { 319 return "\"$str\"" 320} 321