# 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