diff options
Diffstat (limited to 'tcllib/modules/json/json.tcl')
| -rw-r--r-- | tcllib/modules/json/json.tcl | 282 |
1 files changed, 282 insertions, 0 deletions
diff --git a/tcllib/modules/json/json.tcl b/tcllib/modules/json/json.tcl new file mode 100644 index 0000000..90308ac --- /dev/null +++ b/tcllib/modules/json/json.tcl @@ -0,0 +1,282 @@ +# json.tcl -- +# +# JSON parser for Tcl. Management code, Tcl/C detection and selection. +# +# Copyright (c) 2013 by Andreas Kupries + +# @mdgen EXCLUDE: jsonc.tcl + +package require Tcl 8.4 +namespace eval ::json {} + +# ### ### ### ######### ######### ######### +## Management of json implementations. + +# ::json::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::json::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of json requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + # Check for the jsonc 1.1.1 API we are fixing later. + set r [llength [info commands ::json::many_json2dict_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir json_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::json::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::json::SwitchTo {key} { + variable accel + variable loaded + variable apicmds + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + foreach c $apicmds { + rename ::json::${c} ::json::${c}_$loaded + } + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + foreach c $apicmds { + rename ::json::${c}_$key ::json::${c} + } + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +# ::json::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::json::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::json::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::json::KnownImplementations {} { + return {critcl tcl} +} + +proc ::json::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::json { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} + + variable apicmds { + json2dict + many-json2dict + } +} + +# ### ### ### ######### ######### ######### +## Wrapper fix for the jsonc package to match APIs. + +proc ::json::many-json2dict_critcl {args} { + eval [linsert $args 0 ::json::many_json2dict_critcl] +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::json { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Tcl implementation of validation, shared for Tcl and C implementation. +## +## The regexp based validation is consistently faster than json-c. +## Suspected reasons: Tcl REs are mainly in C as well, and json-c has +## overhead in constructing its own data structures. While irrelevant +## to validation json-c still builds them, it has no mode doing pure +## syntax checking. + +namespace eval ::json { + # Regular expression for tokenizing a JSON text (cf. http://json.org/) + + # tokens consisting of a single character + variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," } + variable singleCharTokenRE "\[[join $singleCharTokens {}]\]" + + # quoted string tokens + variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" "." } + variable escapedCharRE "\\\\(?:[join $escapableREs |])" + variable unescapedCharRE {[^\\\"]} + variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\"" + + # as above, for validation + variable escapableREsv { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" } + variable escapedCharREv "\\\\(?:[join $escapableREsv |])" + variable stringREv "\"(?:$escapedCharREv|$unescapedCharRE)*\"" + + # (unquoted) words + variable wordTokens { "true" "false" "null" } + variable wordTokenRE [join $wordTokens "|"] + + # number tokens + # negative lookahead (?!0)[[:digit:]]+ might be more elegant, but + # would slow down tokenizing by a factor of up to 3! + variable positiveRE {[1-9][[:digit:]]*} + variable cardinalRE "-?(?:$positiveRE|0)" + variable fractionRE {[.][[:digit:]]+} + variable exponentialRE {[eE][+-]?[[:digit:]]+} + variable numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?" + + # JSON token, and validation + variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE" + variable tokenREv "$singleCharTokenRE|$stringREv|$wordTokenRE|$numberRE" + + + # 0..n white space characters + set whiteSpaceRE {[[:space:]]*} + + # Regular expression for validating a JSON text + variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenREv))*${whiteSpaceRE}$" +} + + +# Validate JSON text +# @param jsonText JSON text +# @return 1 iff $jsonText conforms to the JSON grammar +# (@see http://json.org/) +proc ::json::validate {jsonText} { + variable validJsonRE + + return [regexp -- $validJsonRE $jsonText] +} + +# ### ### ### ######### ######### ######### +## These three procedures shared between Tcl and Critcl implementations. +## See also package "json::write". + +proc ::json::dict2json {dictVal} { + # XXX: Currently this API isn't symmetrical, as to create proper + # XXX: JSON text requires type knowledge of the input data + set json "" + set prefix "" + + foreach {key val} $dictVal { + # key must always be a string, val may be a number, string or + # bare word (true|false|null) + if {0 && ![string is double -strict $val] + && ![regexp {^(?:true|false|null)$} $val]} { + set val "\"$val\"" + } + append json "$prefix\"$key\": $val" \n + set prefix , + } + + return "\{${json}\}" +} + +proc ::json::list2json {listVal} { + return "\[[join $listVal ,]\]" +} + +proc ::json::string2json {str} { + return "\"$str\"" +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide json 1.3.3 |