Posted to tcl by DS at Tue Nov 23 03:39:48 GMT 2010view raw

  1. #------------------------------------------------------------------------------
  2. # json.ij
  3. # "JavaScript Object Notation"
  4. #------------------------------------------------------------------------------
  5. namespace eval json {
  6. # [escape_jstr str]
  7. # "escape a javascript string"
  8. # arguments:
  9. # "str" - string to escape
  10. # returns:
  11. # quoted javascript string.
  12. array set naughty_jstr [list "<" {\074} "\b" {\b} "\a" {\a} "\t" {\t} {"} "\\\"" ' "\\'" "\\" "\\\\"]
  13. proc escape_jstr {str} {
  14. variable naughty_jstr
  15. set output {}
  16. foreach c [split $str {}] {
  17. binary scan $c H2 n
  18. set v 0x$n
  19. if {$v < 33 && $v != 32} {
  20. append output "\\x$n"
  21. } elseif {$c eq "\v"} {
  22. append output "\\v"
  23. } elseif {$c eq "\f"} {
  24. append output "\\f"
  25. } elseif {$c eq "\r"} {
  26. append output "\\r"
  27. } elseif {$c eq "\n"} {
  28. append output "\\n"
  29. } elseif [info exists naughty_jstr($c)] {
  30. append output $naughty_jstr($c)
  31. } else {
  32. append output $c
  33. }
  34. }
  35. return "\"$output\""
  36. }
  37. array unset json_command
  38. # the rule table. each entry is a list with three
  39. # elements. {expr vars code}
  40. # "expr" - the regular expression (expanded) to match this rule
  41. # "vars" - the match variables to assign from the regexp
  42. # "code" - code to evaluate when this rule is matched
  43. variable _rule
  44. array unset _rule
  45. # [process _indices _var _code]
  46. # "called by [eat] to evaluate code when a rule is matched"
  47. # arguments:
  48. # "_indices" - list of indices
  49. # "_vars" - name of variables to assign strings using the ranges in "_indices"
  50. # "_code" - code to evaluate
  51. # returns:
  52. # list with two elements. first is status, second is result from evaluation.
  53. proc process {_indices _vars _code} {
  54. # collect variables from parent call frame
  55. upvar _next _next
  56. upvar _size _size
  57. upvar _prev _prev
  58. upvar _source _source
  59. # assign the vars
  60. foreach _var $_vars _index $_indices {
  61. set $_var [eval [list string range $_source] $_index]
  62. }
  63. # evaluate the code and return the result
  64. set _status [catch $_code _result]
  65. list $_status $_result
  66. }
  67. # [eat ?rule? ?rule...?]
  68. # "attempt to eat rules"
  69. # arguments:
  70. # "rule" - the name of the rule to match
  71. # returns:
  72. # parsed result
  73. # notes:
  74. # attempts to match rules from first to last. If a rule generates an
  75. # error, [eat] attempts to match the next rule, and so on.
  76. # if a rule generates a "continue" [eat] starts again from the top.
  77. #
  78. # this proc carries the variables (via upvar):
  79. # _size (source size)
  80. # _next (current read pointer)
  81. # _ns_table (namespace table)
  82. # _source (source to parse)
  83. proc eat args {
  84. # the rule table
  85. variable _rule
  86. # the size of the source stream and the previous
  87. # read pointer
  88. upvar _size _size
  89. upvar _next _prev
  90. # have we run out of shit to parse?
  91. #if {$_prev >= $_size} {error "out of data"}
  92. # the source code
  93. upvar _source _source
  94. # foreach named rool
  95. foreach name $args {
  96. # fetch and decode the rule, try to match the expr
  97. set rule $_rule($name)
  98. foreach {expr vars code} $rule {}
  99. set indices [eval [list regexp -inline -indices -expanded -start $_prev -- $expr $_source]]
  100. # did the expr match?
  101. if {[llength $indices] > 0} {
  102. # set the _next pointer to point past the end of the match
  103. set _next [expr {1 + [lindex [lindex $indices 0] 1]}]
  104. # process the code associated with this rule
  105. foreach {status result} [process $indices $vars $code] {}
  106. switch -- $status {
  107. 0 {
  108. # shouldn't happen!
  109. }
  110. 1 {}
  111. 2 {
  112. # continue
  113. uplevel [list set _next $_next]
  114. return $result
  115. }
  116. 4 {
  117. # return
  118. # return a parsed item
  119. set ret [eval [concat eat $args]]
  120. uplevel [list set _next $_next]
  121. return $ret
  122. }
  123. default {
  124. error "shouldn't happen"
  125. }
  126. }
  127. }
  128. }
  129. # no rule matched
  130. error "syntax error"
  131. }
  132. # rule to match nothing
  133. set _rule(nothing) {{\A} match {return {}}}
  134. # rule to ignore whitespace
  135. set _rule(ignore.whitespace) {{\A\s+} match continue}
  136. # rule to match number
  137. # (needs work)
  138. set _rule(number) {
  139. {\A-?[0-9]+(\.[0-9]+)?}
  140. {match}
  141. {return [list number $match]}
  142. }
  143. # rule to match boolean
  144. set _rule(boolean) {{\Atrue|\Afalse} match {return [list boolean $match]}}
  145. # rule to match null
  146. set _rule(undefined) {{\Anull} match {return undefined}}
  147. # rule to match string
  148. set _rule(string) {
  149. {
  150. \A"((?:[^\\"]*(?:\\.)?)*){1,1}"
  151. |
  152. \A'((?:[^\\']*(?:\\.)?)*){1,1}'
  153. }
  154. {match str0 str1}
  155. {return [list string [subst -nocommands -novariables $str0$str1]]}
  156. }
  157. #" (stupid syntax highlighting!)
  158. # rule to match array end "]"
  159. set _rule(endarray) {{\A\]} {match} {return endarray}}
  160. # rule to match comma
  161. set _rule(comma) {{\A\,} {match} {return comma}}
  162. # rule to match colon
  163. set _rule(colon) {{\A\:} {match} {return colon}}
  164. # rule to match object end
  165. set _rule(endobject) {{\A\}} {match} {return endobject}}
  166. # rule to match object
  167. set _rule(object) {
  168. {\A\{}
  169. {match}
  170. {
  171. set tok [eat endobject ignore.whitespace nothing]
  172. if {$tok eq {endobject}} {return {object {}}}
  173. set ret {}
  174. while true {
  175. set key [eat string ignore.whitespace]
  176. eat colon whitespace.ignore
  177. set value [eat object array string undefined boolean number ignore.whitespace]
  178. lappend ret [lindex $key 1] $value
  179. set tok [eat comma endobject ignore.whitespace]
  180. if {$tok eq {endobject}} break
  181. }
  182. return [list object $ret]
  183. }
  184. }
  185. # rule to match array
  186. set _rule(array) {
  187. {\A\[}
  188. {match}
  189. {
  190. set tok [eat endarray ignore.whitespace nothing]
  191. if {$tok eq {endarray}} {return {array {}}}
  192. set ret {}
  193. while true {
  194. lappend ret [eat object array string undefined boolean number ignore.whitespace]
  195. set tok [eat comma endarray ignore.whitespace]
  196. if {$tok eq {endarray}} break
  197. }
  198. return [list array $ret]
  199. }
  200. }
  201. # rule to match end
  202. set _rule(end) {{\A\Z} {match} {return end}}
  203. # [json_decode slave _source]
  204. # "decode JSON string"
  205. set json_command(decode) json_decode
  206. proc json_decode {slave _source} {
  207. # initialize size and current read pointer
  208. set _size [string length $_source]
  209. set _next 0
  210. # eat a JSON object
  211. set ret [eat object array string undefined boolean number ignore.whitespace]
  212. # eat remaining whitespace
  213. eat end ignore.whitespace
  214. return $ret
  215. }
  216. # [json_set slave jsonvar ?key...? jsonvalue]
  217. # "kludgy! works like dict set, but for typed json objects"
  218. # arguments:
  219. # "jsonvar" - name of variable containing JSON object
  220. # "key" - name of key to set
  221. # "jsonvalue" - json value to set
  222. set json_command(set) json_set
  223. proc json_set_rec {json args} {
  224. set arglen [llength $args]
  225. if {$arglen == 0} {return $json}
  226. # TODO: need to validate json object here
  227. if {$arglen == 1} {return [lindex $args 0]}
  228. # modify a sub object
  229. set key [lindex $args 0]
  230. set args [lrange $args 1 end]
  231. set type [lindex $json 0]
  232. # does the object in question actually have properies?
  233. if {[lsearch {undefined string number boolean} $type] != -1} {
  234. error {object has no properties}
  235. }
  236. # modify a sub object
  237. switch -- $type {
  238. object {
  239. array set object [lindex $json 1]
  240. if {[llength $args] == 1} {
  241. # set element
  242. set object($key) [lindex $args 0]
  243. } else {
  244. # modify sub element
  245. set object($key) [eval [list json_set_rec $object($key)] $args]
  246. }
  247. return [list object [array get object]]
  248. }
  249. array {
  250. # set the implicit "length" property of the array?
  251. if {$key eq {length}} {
  252. # length has no properties
  253. if {[llength $args] == 1} {
  254. # TODO: not sure whether to round the index, or force it to be an
  255. # integer ... need to check up on what javascript does ...
  256. set newlenjson [lindex $args 0]
  257. if {[lindex $newlenjson 0] ne {number}} {error {invalid length}}
  258. # make sure length is a positive integer
  259. set newlen [expr {round([lindex $newlenjson 1])}]
  260. if {$newlen < 0} {error {invalid length}}
  261. # get the current array length
  262. set elements [lindex $json 1]
  263. set curlen [llength $elements]
  264. # resize array?
  265. if {$newlen == 0} {
  266. # empty the array
  267. set elements {}
  268. } elseif {$newlen > $curlen} {
  269. # new array entries are undefined
  270. while {[llength $elements] < $newlen} {
  271. lappend elements {undefined}
  272. }
  273. } elseif {$newlen < $curlen} {
  274. # shrink the array
  275. set elements [lrange $elements 0 [expr {$newlen - 1}]]
  276. }
  277. # return the new array
  278. return [list array $elements]
  279. }
  280. # can't set sub object of "length"!
  281. error {object has no properties}
  282. }
  283. # set an array index
  284. set elements [lindex $json 1]
  285. set element [lindex $elements $key]
  286. # make sure the index is valid
  287. if {$element eq {}} {error invalid index}
  288. set element [eval [list json_set_rec $element] $args]
  289. return [list array [lreplace $elements $key $key $element]]
  290. }
  291. }
  292. # oops!
  293. error {invalid JSON object}
  294. }
  295. proc json_set {slave jsonvar args} {
  296. set arglen [llength $args]
  297. # get the value
  298. if {$arglen == 0} {
  299. if {$slave eq {}} {
  300. return [uplevel 2 [list set $jsonvar]]
  301. } else {
  302. return [interp eval $slave [list set $jsonvar]]
  303. }
  304. }
  305. # directly set the value
  306. if {$arglen == 1} {
  307. if {$slave eq {}} {
  308. return [uplevel 2 [list set $jsonvar [lindex $args 0]]]
  309. } else {
  310. return [interp eval $slave [list set $jsonvar [lindex $args 0]]]
  311. }
  312. }
  313. # set a sub element
  314. if {$slave eq {}} {
  315. # call is from master interp, use uplevel
  316. set json [uplevel 2 [list set $jsonvar]]
  317. uplevel 2 [list set $jsonvar [eval [list json_set_rec $json] $args]]
  318. } else {
  319. # call is from slave, use interp eval
  320. set json [interp eval $slave [list set $jsonvar]]
  321. interp eval $slave [list set $jsonvar [eval [list json_set_rec $json] $args]]
  322. }
  323. }
  324. # [json_get slave json ?key...?]
  325. # "get an item from a JSON object"
  326. set json_command(get) json_get
  327. proc json_get {slave json args} {
  328. # return the whole object?
  329. if {$args eq {}} {return $json}
  330. # return a sub object!
  331. set key [lindex $args 0]
  332. set args [lrange $args 1 end]
  333. set type [lindex $json 0]
  334. # does the object in question actually have properies?
  335. if {[lsearch {undefined string number boolean} $type] != -1} {
  336. error {object has no properties}
  337. }
  338. # fetch the sub object
  339. switch -- $type {
  340. object {
  341. # return an object element
  342. array set object [lindex $json 1]
  343. return [eval [list json_get $slave $object($key)] $args]
  344. }
  345. array {
  346. # length property
  347. if {$key eq {length}} {
  348. if {[llength $args] != 0} {error {object has no properties}}
  349. return [list number [llength [lindex $json 1]]]
  350. }
  351. # return an array element, throw an error if the array index
  352. # is out of bounds
  353. set ret [eval [list json_get $slave [lindex [lindex $json 1] $key]] $args]
  354. if {$ret eq {}} {error "invalid index"}
  355. return $ret
  356. }
  357. }
  358. # oops!
  359. error {invalid JSON object}
  360. }
  361. # [json_encode slave json]
  362. # "encode a JSON object"
  363. # arguments:
  364. # "json" - type tagged data to encode
  365. # returns:
  366. # JSON encoded string
  367. set json_command(encode) json_encode
  368. proc json_encode {slave json} {
  369. switch -- [lindex $json 0] {
  370. undefined {return null}
  371. number {
  372. set value [lindex $json 1]
  373. if {[string is double $value]} {return $value}
  374. }
  375. string {return [escape_jstr [lindex $json 1]]}
  376. boolean {
  377. if {[lindex $json 1]} {return true}
  378. return false
  379. }
  380. object {
  381. set items {}
  382. foreach {item value} [lindex $json 1] {
  383. lappend items [escape_jstr $item]:[json_encode $slave $value]
  384. }
  385. return "{[join $items ,]}"
  386. }
  387. array {
  388. set items {}
  389. foreach value [lindex $json 1] {
  390. lappend items [json_encode $slave $value]
  391. }
  392. return "\[[join $items ,]\]"
  393. }
  394. }
  395. error {invalid JSON object}
  396. }
  397. # [json_typeof slave json]
  398. # "return the type of a JSON object"
  399. set json_command(typeof) json_typeof
  400. proc json_typeof {slave json} {
  401. set type [lindex $json 0]
  402. if {[lsearch {undefined string number array object boolean} $type] != -1} {return $type}
  403. error {invalid JSON object}
  404. }
  405. # [json_undefined slave]
  406. # "return an undefined JSON object"
  407. set json_command(undefined) json_undefined
  408. proc json_undefined {slave} {return undefined}
  409. # [json_number slave number]
  410. # "return a JSON number object"
  411. set json_command(number) json_number
  412. proc json_number {slave number} {
  413. if {[string is double $number]} {return [list number $number]}
  414. error {not a number}
  415. }
  416. # [json_object slave ?key value? ?key value...?]
  417. # "return a JSON object"
  418. set json_command(object) json_object
  419. proc json_object {slave args} {
  420. return [list object $args]
  421. }
  422. # [json_string slave string]
  423. # "return a JSON string"
  424. set json_command(string) json_string
  425. proc json_string {slave string} {return [list string $string]}
  426. # [json_boolean slave boolean]
  427. # "return a JSON boolean"
  428. set json_command(boolean) json_boolean
  429. proc json_boolean {slave boolean} {
  430. if {$boolean} {return {boolean true}}
  431. return {boolean false}
  432. }
  433. # [json_array slave ?item...?]
  434. # "return a JSON array"
  435. set json_command(array) json_array
  436. proc json_array {slave args} {return [list array $args]}
  437. # [json command args]
  438. # "json command ensemble"
  439. namespace export json
  440. proc json {command args} {
  441. variable json_command
  442. eval $json_command($command) [list {}] $args
  443. }
  444. proc protected_json {slave command args} {
  445. variable json_command
  446. eval $json_command($command) [list $slave] $args
  447. }
  448.  
  449. proc on_interp_create {interp} {
  450. interp alias $interp json {} [namespace current]::protected_json $interp
  451. }
  452. }
  453. namespace import json::*
  454.