19 changed files with 6839 additions and 4955 deletions
@ -0,0 +1,349 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,349 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,349 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,349 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,349 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
Binary file not shown.
Loading…
Reference in new issue