json.tcl

   1 namespace eval ten::json {
   2
   3   namespace eval deparse {
   4
   5     variable quotes [
   6       list "\"" "\\\"" / \\/ \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t
   7     ]
   8
   9     variable indent
  10     variable indentBy 0
  11     variable indentIncr
  12     variable nl
  13
  14     proc indent_one {} {
  15       variable indentIncr
  16       variable indentBy [ expr $indentBy + $indentIncr ]
  17       variable indent [ string repeat " " $indentBy ]
  18     }
  19
  20     proc outdent_one {} {
  21       variable indentIncr
  22       variable indentBy [ expr $indentBy - $indentIncr ]
  23       variable indent [ string repeat " " $indentBy ]
  24     }
  25
  26     proc str {str} {
  27       variable quotes
  28       return \"[ string map $quotes $str ]\"
  29     }
  30
  31     proc num {num} {
  32       return $num
  33     }
  34
  35     proc decomma {str} {
  36       switch [string index $str end] {
  37         , { string range $str 0 end-1 }
  38         default { return $str }
  39       }
  40     }
  41
  42     proc list {args} {
  43       variable indent
  44       variable nl
  45       set out \[
  46       indent_one
  47       foreach el [lrange $args 0 end] {
  48         append out $nl$indent
  49         append out [ deparse $el ],
  50       }
  51       set out [ decomma $out ]
  52       outdent_one
  53       append out $nl$indent\]
  54       return $out
  55     }
  56
  57     proc obj {args} {
  58       variable indent
  59       variable nl
  60       set out \{
  61       indent_one
  62       dict for {k v} $args {
  63         append out $nl$indent[ str $k ]:\ [ deparse $v ],
  64       }
  65       set out [ decomma $out ]
  66       outdent_one
  67       append out $nl$indent\}
  68     }
  69
  70     proc deparse {data} {
  71       switch -regexp [lindex $data 0] {
  72         ^(true|false|null)$  { lindex $data 0 }
  73         ^(num|str|obj|list)$ { eval $data }
  74         default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] }
  75       }
  76     }
  77   }
  78
  79   proc deparse_json {data {indentIncr 2}} {
  80     set deparse::indentBy 0
  81     set deparse::indentIncr $indentIncr
  82     if [expr $indentIncr == 0] {
  83       set deparse::nl ""
  84     } else {
  85       set deparse::nl "\n"
  86     }
  87     deparse::deparse $data
  88   }
  89
  90   namespace eval tclify {
  91
  92     proc str {str} { return $str }
  93
  94     proc num {num} { return $num }
  95
  96     proc obj {args} {
  97       return $args
  98     }
  99
 100     proc tclify {data} {
 101       switch -regexp [lindex $data 0] {
 102         ^(true|false|null)$ { uplevel 1 return [lindex $data 0] }
 103         ^(num|str|obj|list)$ {}
 104         default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] }
 105       }
 106       eval $data
 107     }
 108   }
 109
 110   proc tclify_json {data} {
 111     tclify::tclify $data
 112   }
 113
 114   namespace eval parse {
 115
 116     variable json
 117
 118     proc eat_spaces {} {
 119       variable json
 120       set json [string trimleft $json]
 121     }
 122
 123     proc eat_char {char} {
 124       variable json
 125       eat_spaces
 126       if {[string index $json 0] eq "$char"} {
 127         eat_any
 128       }
 129     }
 130
 131     proc eat_any {} {
 132       variable json
 133       set json [ string range $json 1 end ]
 134     }
 135
 136     proc parse_list {} {
 137       variable json
 138       eat_any
 139       set tcl {list}
 140       while {"$json" ne ""} {
 141         eat_spaces
 142         if {[string index $json 0] eq "]"} {
 143           eat_any
 144           return $tcl
 145         }
 146         lappend tcl [ parse ]
 147         eat_char ,
 148       }
 149       error "Ran out of JSON. Confused now."
 150     }
 151
 152     proc parse_obj {} {
 153       variable json
 154       eat_any
 155       set tcl {obj}
 156       while {"$json" ne ""} {
 157         eat_spaces
 158         if {[string index $json 0] eq "\}"} {
 159           eat_any
 160           return $tcl
 161         }
 162         eat_spaces
 163         lappend tcl [ parse_str ]
 164         eat_spaces
 165         eat_char :
 166         eat_spaces
 167         lappend tcl [ parse ]
 168         eat_char ,
 169       }
 170       error "Ran out of JSON. Confused now."
 171     }
 172
 173     proc parse_str {} {
 174       variable json
 175       # like Text::Balanced except ugly (borrowed from tcvJSON's code)
 176       set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
 177       if {![regexp $reStr $json string]} {
 178         error "Invalid string: $json"
 179       }
 180       set json [string range $json [string length $string] end]
 181       # chop off outer ""s and substitute backslashes
 182       # This does more than the RFC-specified backslash sequences,
 183       # but it does cover them all
 184       list str [subst -nocommand -novariable [string range $string 1 end-1]]
 185     }
 186
 187     proc parse_num {} {
 188       variable json
 189       string is double -failindex last $json
 190       if {$last == 0} {
 191         error "Saw number but wasn't - $json"
 192       }
 193       set num [string range $json 0 [expr {$last - 1}]]
 194       set json [string range $json $last end]
 195       list num $num
 196     }
 197
 198     proc parse_bare {} {
 199       variable json
 200       if [regexp {^(true|false|null)} $json matched] {
 201         set json [ string range $json [ string length $matched ] end ]
 202         return $matched
 203       } else {
 204         error "Out of ideas parsing: $json"
 205       }
 206     }
 207
 208     proc parse {} {
 209       variable json
 210       eat_spaces
 211       if {$json eq ""} {
 212         return
 213       }
 214       switch -regexp [string index $json 0] {
 215         {\{} { parse_obj }
 216         {\[} { parse_list }
 217         {\"} { parse_str }
 218
 219         {[-0-9]} { parse_num }
 220
 221         default { parse_bare }
 222       }
 223     }
 224   }
 225
 226   proc parse_json {json} {
 227     set parse::json [ string trim $json ]
 228     set result [ parse::parse ]
 229     parse::eat_spaces
 230     if {$parse::json ne ""} {
 231       error "Had JSON left over: $parse::json"
 232     }
 233     return $result
 234   }
 235
 236   namespace export parse_json deparse_json tclify_json
 237 }
 238
 239 set ex_json { list {str foo} {num 0} {obj __remote_object__ {str 512}} {null} }
 240
 241 set jtext {
 242   [
 243     "foo",
 244     0,
 245     {
 246       "__remote_object__": "512",
 247     },
 248     null,
 249   ]
 250 }
 251
 252 namespace eval ten::connection {
 253
 254   proc receive_data_for {name} {
 255
 256
 257   proc conn_setup {name input output initial_handlers} {
 258     variable "${name}_input" $input
 259     variable "${name}_input_closed" ""
 260     variable "${name}_output" $output
 261     variable "${name}_handlers"
 262     array set "${name}_handlers" $initial_handlers
 263     fileevent $input readable [list receive_data_for $name]
 264     puts $output Shere
 265   }
 266
 267   proc run_until_close {name} {
 268     vwait "${name}_input_closed"
 269     set close_value "\$${name}_input_closed"
 270     teardown $name
 271     return $close_value
 272   }
 273
 274   proc teardown {name} {
 275     close [ expr "\$${name}_output" ]
 276     unset "${name}_input"
 277     unset "${name}_input_closed"
 278     unset "${name}_output"
 279     unset "${name}_handlers"
 280   }
 281
 282 namespace import ten::json::*
 283
 284 puts [ deparse_json $ex_json 2 ]
 285
 286 dict for {k v} [ tclify_json [
 287   lindex [ tclify_json $ex_json ] 2
 288 ] ] { puts "$k: $v" }
 289
 290 puts [ parse_json $jtext ]
 291
 292 puts [ parse_json {["foo",2345,["bar"]]} ]