You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
366 lines
9.2 KiB
366 lines
9.2 KiB
# -*- 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.2 |
|
# 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] |
|
} |
|
|
|
|
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
|
#tcl 9+ |
|
proc ::dictn::getdef {dictval path default} { |
|
return [dict getdef $dictval {*}$path $default] |
|
} |
|
|
|
proc ::dictn::getwithdefault {dictval path default} { |
|
return [dict getdef $dictval {*}$path $default] |
|
} |
|
|
|
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 { |
|
#tcl < 9 |
|
proc ::dictn::getdef {dictval path default} { |
|
if {[tcl::dict::exists $dictval {*}$path]} { |
|
return [tcl::dict::get $dictval {*}$path] |
|
} else { |
|
return $default |
|
} |
|
} |
|
proc ::dictn::getwithdefault {dictval path default} { |
|
if {[tcl::dict::exists $dictval {*}$path]} { |
|
return [tcl::dict::get $dictval {*}$path] |
|
} else { |
|
return $default |
|
} |
|
} |
|
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.2 |
|
}] |
|
return |