Keith Vetter 2018-08-15: Another tip I think would be great if implemented is
Tip 508 New subcommand [array default]
. Here's a tcl-only implementation of a new array default subcommand. It uses traces to track whether or not the default value needs to be used.
Also included is a snippet to install the new command into the array ensemble. So you can type
array default set myArr myValue just as the tip specifies.
##+##########################################################################
#
# Tcl only implementation of tip 508 -- array default command
# See tip 508: https://core.tcl-lang.org/tips/doc/trunk/tip/508.md
# by Keith Vetter 2018-08-15
#
# Add our command into the array ensemble
namespace ensemble configure array -map \
[dict merge [namespace ensemble configure array -map] \
{default DefaultArray}]
proc DefaultArray {option arrayName args} {
if {$option ni {get set exists unset}} {
error "bad option $option: must be get, set, exists, or unset"
}
upvar 1 $arrayName $arrayName
if {[info exists $arrayName] && ! [array exists $arrayName]} {
error "$arrayName is not an array"
}
if {$option eq "set"} {
lassign $args value
array set $arrayName {}
# Remove any existing default values
foreach tr [trace info variable $arrayName] {
if {[string first "META: default:" $tr] > -1} {
eval trace remove variable $arrayName $tr
}
}
trace variable $arrayName r [list apply [list {v1 v2 op} "
# META: default: $value
upvar 1 \$v1 \$v1
set exists \[info exists \$v1\\\(\$v2)\]
if {! \$exists} {
array set \$v1 \[list \$v2 $value\]
}
"]]
return
}
if {$option eq "get"} {
if {! [array exists $arrayName]} { error "$arrayName is not an array" }
set t [trace info variable $arrayName]
if {$t eq ""} { error "$arrayName has no default value" }
set n [regexp -line {META: default: (.*)$} $t . value]
if {! $n} { error "internal error: no meta data" }
return $value
}
if {$option eq "exists"} {
if {! [array exists $arrayName]} { return 0 }
set t [trace info variable $arrayName]
set n [regexp -line {META: default: (.*)$} $t . value]
if {! $n} { return 0 }
return 1
}
if {$option eq "unset"} {
if {! [array exists $arrayName]} { return }
foreach tr [trace info variable $arrayName] {
if {[string first "META: default:" $tr] > -1} {
eval trace remove variable $arrayName $tr
}
}
return
}
}Here's some code to show test this command
proc Show {varName cmd expected} {
upvar 1 $varName $varName
set actual [{*}$cmd]
if {$actual eq $expected} {
puts "ok : $cmd => $actual"
} else {
puts "bad : $cmd => $actual :: wanted $expected"
}
}
puts "Testing at the global level"
Show A {array default exists A} 0
Show A {array default exists A} 0
Show A {catch {set A(3)}} 1
Show A {array default set A KPV} ""
Show A {set A(3)} KPV
Show A {set A(4) "xyz"} xyz
Show A {set A(4)} xyz
Show A {array default exists A} 1
Show A {array default unset A} ""
Show A {array default exists A} 0
Show A {set A(3)} KPV
Show A {catch {set A(5)}} 1
proc myProc {} {
puts "\nTesting inside a procedure"
Show AA {array default exists AA} 0
Show AA {array default exists AA} 0
Show AA {catch {set AA(3)}} 1
Show AA {array default set AA KPV} ""
Show AA {set AA(3)} KPV
Show AA {set AA(4) "xyz"} xyz
Show AA {set AA(4)} xyz
Show AA {array default exists AA} 1
Show AA {array default unset AA} ""
Show AA {array default exists AA} 0
Show AA {set AA(3)} KPV
Show AA {catch {set AA(5)}} 1
}
myProc
