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 list {args} {
  36       variable indent
  37       variable nl
  38       set out \[
  39       indent_one
  40       foreach el [lrange $args 0 end] {
  41         append out $nl$indent
  42         append out [ deparse $el ],
  43       }
  44       outdent_one
  45       append out $nl$indent\]
  46       return $out
  47     }
  48
  49     proc obj {args} {
  50       variable indent
  51       variable nl
  52       set out \{
  53       indent_one
  54       dict for {k v} $args {
  55         append out $nl$indent[ str $k ]:\ [ deparse $v ],
  56       }
  57       outdent_one
  58       append out $nl$indent\}
  59     }
  60
  61     proc deparse {data} {
  62       switch -regexp [lindex $data 0] {
  63         ^(true|false|null)$  { lindex $data 0 }
  64         ^(num|str|obj|list)$ { eval $data }
  65         default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] }
  66       }
  67     }
  68   }
  69
  70   proc deparse_json {data {indentIncr 2}} {
  71     set deparse::indentBy 0
  72     set deparse::indentIncr $indentIncr
  73     if [expr $indentIncr == 0] {
  74       set deparse::nl ""
  75     } else {
  76       set deparse::nl "\n"
  77     }
  78     deparse::deparse $data
  79   }
  80
  81   namespace eval tclify {
  82
  83     proc str {str} { return $str }
  84
  85     proc num {num} { return $num }
  86
  87     proc obj {args} {
  88       return $args
  89     }
  90
  91     proc tclify {data} {
  92       switch -regexp [lindex $data 0] {
  93         ^(true|false|null)$ { uplevel 1 return [lindex $data 0] }
  94         ^(num|str|obj|list)$ {}
  95         default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] }
  96       }
  97       eval $data
  98     }
  99   }
 100
 101   proc tclify_json {data} {
 102     tclify::tclify $data
 103   }
 104
 105   namespace eval parse {
 106
 107     variable json
 108
 109     proc eat_spaces {} {
 110       variable json
 111       set json [string trimleft $json]
 112     }
 113
 114     proc eat_char {char} {
 115       variable json
 116       eat_spaces
 117       if {[string index $json 0] eq "$char"} {
 118         eat_any
 119       }
 120     }
 121
 122     proc eat_any {} {
 123       variable json
 124       set json [ string range $json 1 end ]
 125     }
 126
 127     proc parse_list {} {
 128       variable json
 129       eat_any
 130       set tcl {list}
 131       while {"$json" ne ""} {
 132         eat_spaces
 133         if {[string index $json 0] eq "]"} {
 134           eat_any
 135           return $tcl
 136         }
 137         lappend tcl [ parse ]
 138         eat_char ,
 139       }
 140       error "Ran out of JSON. Confused now."
 141     }
 142
 143     proc parse_obj {} {
 144       variable json
 145       eat_any
 146       set tcl {obj}
 147       while {"$json" ne ""} {
 148         eat_spaces
 149         if {[string index $json 0] eq "\}"} {
 150           eat_any
 151           return $tcl
 152         }
 153         eat_spaces
 154         lappend tcl [ parse_str ]
 155         eat_spaces
 156         eat_char :
 157         eat_spaces
 158         lappend tcl [ parse ]
 159         eat_char ,
 160       }
 161       error "Ran out of JSON. Confused now."
 162     }
 163
 164     proc parse_str {} {
 165       variable json
 166       # like Text::Balanced except ugly (borrowed from tcvJSON's code)
 167       set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
 168       if {![regexp $reStr $json string]} {
 169         error "Invalid string: $json"
 170       }
 171       set json [string range $json [string length $string] end]
 172       # chop off outer ""s and substitute backslashes
 173       # This does more than the RFC-specified backslash sequences,
 174       # but it does cover them all
 175       list str [subst -nocommand -novariable [string range $string 1 end-1]]
 176     }
 177
 178     proc parse_num {} {
 179       variable json
 180       string is double -failindex last $json
 181       if {$last == 0} {
 182         error "Saw number but wasn't - $json"
 183       }
 184       set num [string range $json 0 [expr {$last - 1}]]
 185       set json [string range $json $last end]
 186       list num $num
 187     }
 188
 189     proc parse_bare {} {
 190       variable json
 191       if [regexp {^(true|false|null)} $json matched] {
 192         set json [ string range $json [ string length $matched ] end ]
 193         return $matched
 194       } else {
 195         error "Out of ideas parsing: $json"
 196       }
 197     }
 198
 199     proc parse {} {
 200       variable json
 201       eat_spaces
 202       if {$json eq ""} {
 203         return
 204       }
 205       switch -regexp [string index $json 0] {
 206         {\{} { parse_obj }
 207         {\[} { parse_list }
 208         {\"} { parse_str }
 209
 210         {[-0-9]} { parse_num }
 211
 212         default { parse_bare }
 213       }
 214     }
 215   }
 216
 217   proc parse_json {json} {
 218     set parse::json [ string trim $json ]
 219     set result [ parse::parse ]
 220     parse::eat_spaces
 221     if {$parse::json ne ""} {
 222       error "Had JSON left over: $parse::json"
 223     }
 224     return $result
 225   }
 226 }
 227
 228 set ex_json { list {str foo} {num 0} {obj __remote_object__ {str 512}} {null} }
 229
 230 set jtext {
 231   [
 232     "foo",
 233     0,
 234     {
 235       "__remote_object__": "512",
 236     },
 237     null,
 238   ]
 239 }
 240
 241 puts [ ten::json::deparse_json $ex_json 2 ]
 242
 243 dict for {k v} [ ten::json::tclify_json [
 244   lindex [ ten::json::tclify_json $ex_json ] 2
 245 ] ] { puts "$k: $v" }
 246
 247 puts [ ten::json::parse_json $jtext ]
 248
 249 puts [ ten::json::parse_json {["foo",2345,["bar"]]} ]