Posted to tcl by DS at Tue Nov 23 03:22:43 GMT 2010view raw

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