Posted to tcl by evilotto at Fri Sep 08 20:53:16 GMT 2017view raw
- package require rl_json
- namespace eval ::jsb {
- variable current {}
- variable ctx {}
- proc build {script} {
- variable current
- set current {}
- set cpath [uplevel namespace path]
- uplevel [list namespace path [list {*}$cpath ::jsb]]
- ctx val val $script
- uplevel [list namespace path $cpath]
- try {
- set json [rl_json::json new {*}[lindex $current 0]]
- } on error e {
- puts "$e trying to format \n\t$current"
- }
- return $json
- }
- proc ctx {req cur script} {
- variable ctx
- set cc [lindex $ctx end]
- if {$cc ne $req} {
- error "invalid context for $cur (is $cc, needs $req)"
- }
- if {$cur ne "-"} {
- lappend ctx $cur
- uplevel 2 $script
- set ctx [lrange $ctx 0 end-1]
- } else {
- uplevel 1 $script
- }
- }
- proc Obj {script} {
- variable current
- set cval $current
- set current {}
- ctx val obj $script
- set current [list {*}$cval [list object {*}$current]]
- }
- proc Entry {k script} {
- variable current
- set cval $current
- set current {}
- ctx obj val $script
- set current [list {*}$cval $k {*}$current]
- }
- proc Array {script} {
- variable current
- set cval $current
- set current {}
- ctx val val $script
- set current [list {*}$cval [list array {*}$current]]
- }
- proc Null {} {
- variable current
- ctx val - {lappend current null}
- }
- proc Number {v} {
- variable current
- ctx val - {lappend current [list number $v]}
- }
- proc String {s} {
- variable current
- ctx val - {lappend current [list string $s]}
- }
- }
- ### usage ###
- puts [jsb::build {
- Obj {
- Entry woo {String baz}
- Entry zoo {
- Array {
- Null
- Obj {
- Entry a {Null}
- for {set a 0} {$a < 10} {incr a} {
- Entry "a$a" {Number $a}
- }
- }
- }
- }
- }
- }]
- ### results in:
- # {"woo":"baz","zoo":[null,{"a":null,"a0":0,"a1":1,"a2":2,"a3":3,"a4":4,"a5":5,"a6":6,"a7":7,"a8":8,"a9":9}]}