X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=json.tcl;h=1acd13f16877d6d2146f9e0e52b36ed5ff59ec72;hb=3c6a0ce7ac46c66d6b7b48d63cbfc0470ae991e1;hp=659c152977ad918d3948477fffb88984e39c6d4d;hpb=7b31d3c356d8f567075ac5118b9449b0bc3292cb;p=scpubgit%2FTenDotTcl.git diff --git a/json.tcl b/json.tcl index 659c152..1acd13f 100644 --- a/json.tcl +++ b/json.tcl @@ -32,6 +32,13 @@ namespace eval ten::json { return $num } + proc decomma {str} { + switch [string index $str end] { + , { string range $str 0 end-1 } + default { return $str } + } + } + proc list {args} { variable indent variable nl @@ -39,8 +46,9 @@ namespace eval ten::json { indent_one foreach el [lrange $args 0 end] { append out $nl$indent - append out [ eval $el ], + append out [ deparse $el ], } + set out [ decomma $out ] outdent_one append out $nl$indent\] return $out @@ -52,18 +60,19 @@ namespace eval ten::json { set out \{ indent_one dict for {k v} $args { - append out $nl$indent[ str $k ]:\ [ eval $v ], + append out $nl$indent[ str $k ]:\ [ deparse $v ], } + set out [ decomma $out ] outdent_one append out $nl$indent\} } - proc deparse {args} { - switch -regexp [lindex $args 0] { - ^num|str|obj|list$ - - default { error "Invalid JSON type [lindex $args 0]" } + proc deparse {data} { + switch -regexp [lindex $data 0] { + ^(true|false|null)$ { lindex $data 0 } + ^(num|str|obj|list)$ { eval $data } + default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] } } - return [ eval $args ] } } @@ -75,10 +84,209 @@ namespace eval ten::json { } else { set deparse::nl "\n" } - namespace inscope deparse eval $data + deparse::deparse $data } + + namespace eval tclify { + + proc str {str} { return $str } + + proc num {num} { return $num } + + proc obj {args} { + return $args + } + + proc tclify {data} { + switch -regexp [lindex $data 0] { + ^(true|false|null)$ { uplevel 1 return [lindex $data 0] } + ^(num|str|obj|list)$ {} + default { error [ concat "Invalid JSON type " [lindex $data 0 0] ] } + } + eval $data + } + } + + proc tclify_json {data} { + tclify::tclify $data + } + + namespace eval parse { + + variable json + + proc eat_spaces {} { + variable json + set json [string trimleft $json] + } + + proc eat_char {char} { + variable json + eat_spaces + if {[string index $json 0] eq "$char"} { + eat_any + } + } + + proc eat_any {} { + variable json + set json [ string range $json 1 end ] + } + + proc parse_list {} { + variable json + eat_any + set tcl {list} + while {"$json" ne ""} { + eat_spaces + if {[string index $json 0] eq "]"} { + eat_any + return $tcl + } + lappend tcl [ parse ] + eat_char , + } + error "Ran out of JSON. Confused now." + } + + proc parse_obj {} { + variable json + eat_any + set tcl {obj} + while {"$json" ne ""} { + eat_spaces + if {[string index $json 0] eq "\}"} { + eat_any + return $tcl + } + eat_spaces + lappend tcl [ parse_str ] + eat_spaces + eat_char : + eat_spaces + lappend tcl [ parse ] + eat_char , + } + error "Ran out of JSON. Confused now." + } + + proc parse_str {} { + variable json + # like Text::Balanced except ugly (borrowed from tcvJSON's code) + set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))} + if {![regexp $reStr $json string]} { + error "Invalid string: $json" + } + set json [string range $json [string length $string] end] + # chop off outer ""s and substitute backslashes + # This does more than the RFC-specified backslash sequences, + # but it does cover them all + list str [subst -nocommand -novariable [string range $string 1 end-1]] + } + + proc parse_num {} { + variable json + string is double -failindex last $json + if {$last == 0} { + error "Saw number but wasn't - $json" + } + set num [string range $json 0 [expr {$last - 1}]] + set json [string range $json $last end] + list num $num + } + + proc parse_bare {} { + variable json + if [regexp {^(true|false|null)} $json matched] { + set json [ string range $json [ string length $matched ] end ] + return $matched + } else { + error "Out of ideas parsing: $json" + } + } + + proc parse {} { + variable json + eat_spaces + if {$json eq ""} { + return + } + switch -regexp [string index $json 0] { + {\{} { parse_obj } + {\[} { parse_list } + {\"} { parse_str } + + {[-0-9]} { parse_num } + + default { parse_bare } + } + } + } + + proc parse_json {json} { + set parse::json [ string trim $json ] + set result [ parse::parse ] + parse::eat_spaces + if {$parse::json ne ""} { + error "Had JSON left over: $parse::json" + } + return $result + } + + namespace export parse_json deparse_json tclify_json +} + +set ex_json { list {str foo} {num 0} {obj __remote_object__ {str 512}} {null} } + +set jtext { + [ + "foo", + 0, + { + "__remote_object__": "512", + }, + null, + ] } -puts [ ten::json::deparse_json { - list {str foo} {num 0} {obj __remote_object__ {str 512}} -} 0 ] +namespace eval ten::connection { + + proc receive_data_for {name} { + + + proc conn_setup {name input output initial_handlers} { + variable "${name}_input" $input + variable "${name}_input_closed" "" + variable "${name}_output" $output + variable "${name}_handlers" + array set "${name}_handlers" $initial_handlers + fileevent $input readable [list receive_data_for $name] + puts $output Shere + } + + proc run_until_close {name} { + vwait "${name}_input_closed" + set close_value "\$${name}_input_closed" + teardown $name + return $close_value + } + + proc teardown {name} { + close [ expr "\$${name}_output" ] + unset "${name}_input" + unset "${name}_input_closed" + unset "${name}_output" + unset "${name}_handlers" + } + +namespace import ten::json::* + +puts [ deparse_json $ex_json 2 ] + +dict for {k v} [ tclify_json [ + lindex [ tclify_json $ex_json ] 2 +] ] { puts "$k: $v" } + +puts [ parse_json $jtext ] + +puts [ parse_json {["foo",2345,["bar"]]} ]