Tip #508

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 add variable $arrayName read [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

Enter Category Here