**rl_json Extensions **

[Napier] (Dash Automation) - 11/27/2016

[rl_json] allows us to operate on json in a similar fashion (and speed) to operating on dict itself.  We use the [dict extensions] utility procedures often so we also wanted to move some of the options to be able to work on json as well.  The result are some very convenient options for operating on json objects! You must have
the rl_json extension for this to work!

The json namespace has an unknown proc defined to forward any unknown commands to ::rl_json::json so that you can run any of the json commands as if you imported it directly (json set ...) (json get_typed ...)

**Summary of Commands**

**** json exists ''json_val'' ...?path? ... ****

======

# Summary:
# Extends the native rl_json exists to handle the quirk it has in handling
# of an empty string ({}).  Since a JSON object is valid when it is an empty
# but properly formatted json object, exists will not throw an error with this
# workaround and will perform as expected (returning false since nothing exists)

set j {{"foo": "bar"}}

puts [json exists $j foo]
# 0

======


**** json get? ''json_val'' ...?path? ... ****

======

# Summary:
# Attempt to get the json value (returned as a dict) of the path.  If the
# path does not exist, returns {} rather than an error.

set j {{"foo": "bar", "baz": null, "qux": true, "tux": 900}}

set v [json get? $j randomKey]
# {}

======

**** json validate ''json_val'' ****

======

# Summary:
# Attempt to validate that a given value is a json object.  This was taken from the
# tcllib json package so that it does not also need to be required for this package
# to operate properly.

set j {{"foo": "bar", "baz": null, "qux": true, "tux": 900}}

if { [json isjson $j] } {
  puts "Validated"
} else { puts "Not Validated" }
# "Validated"

======

**** json push varname ...?varname?... ****

======

# Summary:
# Attempt to validate that a given value is a json object.  This was taken from the
# tcllib json package so that it does not also need to be required for this package
# to operate properly.

set j {{"foo": "bar", "baz": null}}

set qux true
set value 900
set value2 {}

json push j qux {value tux} {value2 nux null}
# {"foo":"bar","baz":null,"qux":true,"tux":900,"nux":null}

======

**** json pull varname ...?varname?... ****

======

# Summary:
# Pull keys from the json object and create them as local variables in the
# callers scope.  Optionally provide the variables name, the default value 
# if the key was not found, and a path to the key.
# - Each element is either the name of the key or a list of $key $newName $default ...$path
#   where items in the list are optional.

set j {{ "foo": "bar", "baz": { "qux": true, "tux": 900 } }}

json pull j foo [list tux TUX {} baz]

puts $foo;  # bar
puts $TUX;  # 900

======


**** json pullFrom varname ...?varname?... ****

======

# Summary:
# Similar to json pull, this allows you to provide a list as the first 
# argument to define the path you wish to operate from as a root.
# - Each argument may still specify the same arguments as in json pull
#   except that it will operate from the given main path.

set j {{ "foo": "bar", "baz": { "qux": true, "tux": 900 } }}

json pullFrom [list j baz] qux tux

puts $qux;  # true
puts $tux;  # 900

======


**** json pick ''json_value'' ...?keyname?... ****

======

# Summary:
# Returns a new json object comprised of the given keys (if they existed in the
# original json object).  

set j {{ "foo": "bar", "baz": { "qux": true, "tux": 900 }, "yaz": null }}

set new [json pick $j foo baz some other values]
# {"foo":"bar","baz":{"qux":true,"tux":900}}

======


**** json withKey ''json_value'' key ****

======

# Summary:
# Iterates through a json object and attempts to retrieve one of its childs
# value ($key) and assigns that as the main keys value.

set j {{ "foo": { "bar": null, "baz": 900 }, "qux": { "bar": true, "baz": 1800 } }}

set new [json withKey $j baz]
# {"foo":900,"qux":1800}

======

**** json modify varname ''dict_value'' ****

======

# Summary:
# Modifies a given json object in place. The value can be a dict or an even
# number of arguments.

set j {{"foo": "bar", "baz": null, "qux": true, "tux": 900}}

json modify j [dict create foo nux qux false new value]
# {"foo":"nux","baz":null,"qux":false,"tux":900,"new":"value"}

======


**** json typed value ..?opts?... ****

======

# Summary:
# Does a "best attempt" to discover and handle the value of an item and convert it
# to a json object or value.  Primitive support for properly built nested data 
# structures but should not be relied upon for that.  This is generally used to
# convert to a json value (example: hi -> "hi") and will first confirm the value
# is not already a json value (example: "hi" -> "hi")
# 
# This is a key ingredient to allowing many of the other functions to work.

json typed foo; # "foo"
json typed {"foo"} ; # "foo"
json typed [list one two three]; # ["one", "two", "three"]
json typed [dict create foo bar baz qux]; # {"foo": "bar", "baz": "qux"}
json typed [list [dict create foo bar] [dict create baz qux]]; # [ {"foo": "bar"} {"baz": "qux"} ]

======

-------------
**The Script**

======

# Require the rl_json extension
package require rl_json

# Taken from the json tcllib package for validation
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
  ::variable whiteSpaceRE {[[:space:]]*}
  # Regular expression for validating a JSON text
  ::variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenREv))*${whiteSpaceRE}$"
  # 
  ::namespace ensemble create -unknown [::list ::json::unknown]
        ::namespace export {[a-z]*}
}



proc ::json::rl        args { ::tailcall ::rl_json::json {*}$args           }
proc ::json::get       args { ::tailcall ::rl_json::json get       {*}$args }
proc ::json::set       args { ::tailcall ::rl_json::json set       {*}$args }
proc ::json::new       args { ::tailcall ::rl_json::json new       {*}$args }
proc ::json::json2dict args { ::tailcall ::rl_json::json get       {*}$args }
proc ::json::get_typed args { ::tailcall ::rl_json::json get_typed {*}$args }
proc ::json::type      args { ::tailcall ::rl_json::json type      {*}$args }
proc ::json::template  args { ::tailcall ::rl_json::json template  {*}$args }
proc ::json::normalize args { ::tailcall ::rl_json::json normalize {*}$args }
proc ::json::unset     args { ::tailcall ::rl_json::json unset     {*}$args }
proc ::json::extract   args { ::tailcall ::rl_json::json extract   {*}$args }
proc ::json::foreach   args { ::tailcall ::rl_json::json foreach   {*}$args }
proc ::json::lmap      args { ::tailcall ::rl_json::json lmap      {*}$args }

# Extends the native rl_json exists to handle the quirk it has in handling
# of an empty string ({}).  Since a JSON object is valid when it is an empty
# but properly formatted json object, exists will not throw an error with this
# workaround and will perform as expected (returning false since nothing exists)
proc ::json::exists { j args } {
  ::switch -- $j {
    {} - {{}} { ::return 0 } default {
      ::if { ! [ validate $j ] } { ::return 0 }
      ::return [ rl exists $j {*}$args ]
    }
  }
}

# Attempt to get the json value (returned as a dict) of the path.  If the
# path does not exist, returns {} rather than an error.
proc ::json::get?      args {
  ::if { [ exists {*}$args ] } {
    ::tailcall ::rl_json::json get {*}$args
  } else { ::return }
}

# Attempt to validate that a given value is a json object, returns bool
proc ::json::isjson   v { ::tailcall json validate $v }
proc ::json::validate v {
  ::variable validJsonRE
  ::return [ ::regexp -- $validJsonRE $v ]
}

# Push local variables into the json object while optionally transforming 
# the keys and/or default value should the value of the variable be {}

proc ::json::push { vname args } {
  ::if { $vname ne "->" } { ::upvar 1 $vname rj }
  ::if { ! [::info exists rj] } { ::set rj {{}} }
  ::foreach arg $args {
    ::set default [::lassign $arg variable name]
    ::upvar 1 $variable value
    ::if { [::info exists value] } {
      ::if { $name eq {} } { ::set name $variable }
      ::if { $value ne {} } {
        set rj $name [typed $value]
      } else { set rj $name [typed $default] }
    } else { ::throw error "$variable doesn't exist when trying to push $name into dict $var" }
  }
  ::return $rj
}

# Pull keys from the json object and create them as local variables in the
# callers scope.  Optionally provide the variables name, the default value 
# if the key was not found, and a path to the key.
# - Each element is either the name of the key or a list of $key $newName $default ...$path
#   where items in the list are optional.
proc ::json::pull { vname args } {
  ::upvar 1 $vname check
  ::if { [::info exists check] } {
    ::set j $check
  } else { ::set j $vname }
  ::set rj {{}}
  ::foreach v $args {
    ::set path [::lassign $v variable name default]
    ::if { $name eq {} } { ::set name $variable }
    ::upvar 1 $name value
    ::if { [exists $j {*}$path $variable] } {
      ::lassign [get_typed $j {*}$path $variable] value type
      ::set ex  [extract $j {*}$path $variable]
      set rj {*}$path $name $ex 
    } else { ::set value $default }
  }
  ::return $rj
}

# Similar to json pull, this allows you to provide a list as the first 
# argument to define the path you wish to operate from as a root.
# - Each argument may still specify the same arguments as in json pull
#   except that it will operate from the given main path.
proc ::json::pullFrom { vname args } {
  ::set mpath [::lassign $vname var]
  ::upvar 1 $var check
  ::if { [::info exists check] } { 
    ::set j $check
  } else { ::set j $var }
  ::set rj {{}}
  ::foreach v $args {
    ::set path [::lassign $v variable name default]
    ::if { $name eq {} } { ::set name $variable }
    ::upvar 1 $name value
    ::if { [ exists $j {*}$mpath $variable {*}$path ] } {
      ::set value [ get $j {*}$mpath $variable {*}$path ]
      set rj $name [extract $j {*}$mpath $variable {*}$path]
    } elseif { $default ne {} } {
      ::set value $default
      set rj $name $default
    } else { ::set value {} }
  }
  ::return $rj 
}

proc ::json::destruct args {
  
}

# Returns a new json object comprised of the given keys (if they existed in the
# original json object).  
proc ::json::pick { var args } {
  ::set rj {{}}
  ::foreach arg $args {
    ::set path [::lrange  $arg 0 end-1]
    ::set as   [::lindex  $arg end]
    ::if { [exists $var {*}$path $as] } {
      set rj $as [extract $var {*}$path $as]
    }
  }
  ::return $rj
}

# Iterates through a json object and attempts to retrieve one of its childs
# value ($key) and assigns that as the main keys value.
proc ::json::withKey { var key } { 
  ::set rj {{}}
  rl foreach {k v} $var {
    ::if { [exists $v $key] } { set rj $k [extract $var $k $key] }
  }
  ::return $rj
}

# Modifies a given json object in place. The value can be a dict or an even
# number of arguments.
proc ::json::modify { vname args } {
  ::upvar 1 $vname rj
  ::if { ! [::info exists rj] } { ::set rj {{}} }
  ::if { [::llength $args] == 1 } { ::set args [::lindex $args 0] }
  ::dict for { k v } $args { set rj $k [typed $v] }
  ::return $rj
}

# Does a "best attempt" to discover and handle the value of an item and convert it
# to a json object or value.  Primitive support for properly built nested data 
# structures but should not be relied upon for that.  This is generally used to
# convert to a json value (example: hi -> "hi") and will first confirm the value
# is not already a json value (example: "hi" -> "hi")
# This should only be relied upon for simple value transformations.
proc ::json::typed {value args} {
  ::regexp {^value is a (.*?) with a refcount} \
    [::tcl::unsupported::representation $value] -> type
  ::if { "-map" ni $args && ! [ ::catch { type $value } err ] } { ::return $value }
  ::switch -glob -- $type {
    dict   { 
      ::set obj {}
      ::dict for { k v } $value {
        ::lappend obj $k [ typed $v -map ]  
      }
      ::if { "-map" in $args } { ::return "object $obj" }
      ::return [new object {*}$obj]
    }
    *array - list {
      ::set arr {}
      ::set i 0
      ::foreach v $value {
        ::set v [ typed $v -map ]
        ::if { $i == 0 && [::lindex $v 0] eq "array" && [::llength [::lindex $v 1]] == 2 } {
          ::set v [::lindex $v 1]
        }
        ::incr i
        ::lappend arr $v
      }
      ::if { "-map" in $args } { ::return "array $arr" }
      ::return [new array {*}$arr]
    }
    int - double  {
      ::if { "-map" in $args } { ::return "number [::expr {$value}]" }
      ::return [::expr {$value}]
    }
    boolean* { 
      ::if { "-map" in $args } { ::return "boolean [::expr {bool($value)}]" }
      ::return [::expr {bool($value)}] }
    *string - default {
      ::if {$value eq "null"} {
        ::return $value
      } elseif {[::string is entier -strict $value]} {
        ::if { "-map" in $args } { ::return "number [::expr {$value}]" }
        ::return [::expr {$value}]
      } elseif {[::string is double  -strict $value]} {
        ::if { "-map" in $args } { ::return "number [::expr {$value}]" }
        ::return [::expr {$value}]
      } elseif {[::string is boolean -strict $value]} {
        ::if { "-map" in $args } { ::return "boolean [::expr {bool($value)}]" }
        ::return [::expr {bool($value)}]
      }
    }
  }
  ::if { "-map" in $args } { ::return "string [new string $value]" }
  ::return [new string $value] 
}

# In-case new commands are added to rl_json we pass them through to the 
# rl_json procedure.  When handled with tailcall we should see a speed
# improvement of the handling (have yet to benchmark it).
proc ::json::unknown { ns cmd args } { 
  ::switch -- $cmd {
    default {
      ::return [ ::list ::rl_json::json $cmd ]
    }
  }
}
======

<<categories>> Data Structure | Command