lib_tcl/widget/util.tcl

# util.tcl --
#
#	This file implements package ::Utility, which  ...
#
# Copyright (c) 1997-8 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

## The provide goes first to prevent the recursive provide/require
## loop for subpackages
package provide ::Utility 1.0

## This assumes that all util-*.tcl files are in the same directory
if {[lsearch -exact $auto_path [file dirname [info script]]]==-1} {
    lappend auto_path [file dirname [info script]]
}

namespace eval ::Utility {;

## Protos
namespace export -clear *

proc get_opts args {}
proc get_opts2 args {}
proc lremove args {}
proc lrandomize args {}
proc lunique args {}
proc luniqueo args {}
proc line_append args {}
proc highlight args {}
proc echo args {}
proc alias args {}
proc which args {}
proc ls args {}
proc dir args {}
proc fit_format args {}
proc validate args {}
proc allow_null_elements args {}
proc deny_null_elements args {}

}; # end of ::Utility namespace prototype headers

package require ::Utility::number
package require ::Utility::string
package require ::Utility::dump
package require ::Utility::expand
package require ::Utility::tk

namespace eval ::Utility {;

foreach namesp [namespace children [namespace current]] {
    namespace import -force ${namesp}::*
}

# psource --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
;proc psource {file namesp {import *}} {
    uplevel \#0 [subst {
	source $file
	namespace import -force ${namesp}::$import
    }
    ]
}

# get_opts --
#
#   Processes -* named options, with or w/o possible associated value
#   and returns remaining args
#
# Arguments:
#   var		variable into which option values should be stored
#   arglist	argument list to parse
#   optlist	list of valid options with default value
#   typelist	optional list of option types that can be used to
#		validate incoming options
#   nocomplain	whether to complain about unknown -switches (0 - default)
#		or not (1)
# Results:
#   Returns unprocessed arguments.
#
;proc get_opts {var arglist optlist {typelist {}} {nocomplain 0}} {
    upvar 1 $var data

    if {![llength $optlist] || ![llength $arglist]} { return $arglist }
    array set opts $optlist
    array set types $typelist
    set i 0
    while {[llength $arglist]} {
	set key [lindex $arglist $i]
	if {[string match -- $key]} {
	    set arglist [lreplace $arglist $i $i]
	    break
	} elseif {![string match -* $key]} {
	    break
	} elseif {[string match {} [set akey [array names opts $key]]]} {
	    set akey [array names opts ${key}*]
	}
	switch [llength $akey] {
	    0		{ ## oops, no keys matched
		if {$nocomplain} {
		    incr i
		} else {
		    return -code error "unknown switch '$key', must be:\
			    [join [array names opts] {, }]"
		}
	    }
	    1		{ ## Perfect, found just the right key
		if {$opts($akey)} {
		    set val [lrange $arglist [expr {$i+1}] \
			    [expr {$i+$opts($akey)}]]
		    set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]]
		    if {[info exists types($akey)] && \
			    ([string compare none $types($akey)] && \
			    ![validate $types($akey) $val])} {
			return -code error "the value for \"$akey\" is not in\
				proper $types($akey) format"
		    }
		    set data($akey) $val
		} else {
		    set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]]
		    set data($akey) 1
		}
	    }
	    default	{ ## Oops, matches too many possible keys
		return -code error "ambiguous option \"$key\",\
			must be one of: [join $akey {, }]"
	    }
	}
    }
    return $arglist
}

# get_opts2 --
#
#   Process options into an array.  -- short-circuits the processing
#
# Arguments:
#   var		variable into which option values should be stored
#   arglist	argument list to parse
#   optlist	list of valid options with default value
#   typelist	optional list of option types that can be used to
#		validate incoming options
# Results:
#   Returns unprocessed arguments.
#
;proc get_opts2 {var arglist optlist {typelist {}}} {
    upvar 1 $var data

    if {![llength $optlist] || ![llength $arglist]} { return $arglist }
    array set data $optlist
    array set types $typelist
    foreach {key val} $arglist {
	if {[string match -- $key]} {
	    set arglist [lreplace $arglist 0 0]
	    break
	}
	if {[string match {} [set akey [array names data $key]]]} {
	    set akey [array names data ${key}*]
	}
	switch [llength $akey] {
	    0		{ ## oops, no keys matched
		return -code error "unknown switch '$key', must be:\
			[join [array names data] {, }]"
	    }
	    1		{ ## Perfect, found just the right key
		if {[info exists types($akey)] && \
			![validate $types($akey) $val]} {
		    return -code error "the value for \"$akey\" is not in\
			    proper $types($akey) format"
		}
		set data($akey) $val
	    }
	    default	{ ## Oops, matches too many possible keys
		return -code error "ambiguous option \"$key\",\
			must be one of: [join $akey {, }]"
	    }
	}
	set arglist [lreplace $arglist 0 1]
    }
    return $arglist
}

# lremove --
#   remove items from a list
# Arguments:
#   ?-all?	remove all instances of said item
#   list	list to remove items from
#   args	items to remove
# Returns:
#   The list with items removed
#
;proc lremove {args} {
    set all 0
    if {[string match \-a* [lindex $args 0]]} {
	set all 1
	set args [lreplace $args 0 0]
    }
    set l [lindex $args 0]
    foreach i [join [lreplace $args 0 0]] {
	if {[set ix [lsearch -exact $l $i]] == -1} continue
	set l [lreplace $l $ix $ix]
	if {$all} {
	    while {[set ix [lsearch -exact $l $i]] != -1} {
		set l [lreplace $l $ix $ix]
	    }
	}
    }
    return $l
}

# lrandomize --
#   randomizes a list
# Arguments:
#   ls		list to randomize
# Returns:
#   returns list in with randomized items
#
;proc lrandomize ls {
    set res {}
    while {[string compare $ls {}]} {
	set i [randrng [llength $ls]]
	lappend res [lindex $ls $i]
	set ls [lreplace $ls $i $i]
    }
    return $res
}

# lunique --
#   order independent list unique proc, not most efficient.
# Arguments:
#   ls		list of items to make unique
# Returns:
#   list of only unique items, order not defined
#
;proc lunique ls {
    foreach l $ls {set ($l) x}
    return [array names {}]
}

# lunique --
#   order independent list unique proc.  most efficient, but requires
#   __LIST never be an element of the input list
# Arguments:
#   __LIST	list of items to make unique
# Returns:
#   list of only unique items, order not defined
#
;proc lunique __LIST {
    if {[llength $__LIST]} {
	foreach $__LIST $__LIST break
	unset __LIST
	return [info locals]
    }
}

# luniqueo --
#   order dependent list unique proc
# Arguments:
#   ls		list of items to make unique
# Returns:
#   list of only unique items in same order as input
#
;proc luniqueo ls {
    set rs {}
    foreach l $ls {
	if {[info exist ($l)]} { continue }
	lappend rs $l
	set ($l) 0
    }
    return $rs
}

# flist --
#
#   list open files and sockets
#
# Arguments:
#   pattern	restrictive regexp pattern for numbers
#   manum	max socket/file number to search until
# Results:
#   Returns ...
#
;proc flist {{pattern .*} {maxnum 1025}} {
    set result {}
    for {set i 1} {$i <= $maxnum} {incr i} {
	if {![regexp $pattern $i]} { continue }
        if {![catch {fconfigure file$i} conf]} {
            lappend result [list file$i $conf]
        }
        if {![catch {fconfigure sock$i} conf]} {
            array set c {-peername {} -sockname {}}
            array set c $conf
            lappend result [list sock$i $c(-peername) $c(-sockname)]
        }
    }
    return $result
}


# highlight --
#
#    searches in text widget for $str and highlights it
#    If $str is empty, it just deletes any highlighting
#    This really belongs in ::Utility::tk
#
# Arguments:
#   w			text widget
#   str			string to search for
#   -nocase		specifies to be case insensitive
#   -regexp		specifies that $str is a pattern
#   -tag   tagId	name of tag in text widget
#   -color color	color of tag in text widget
# Results:
#   Returns ...
#
;proc highlight {w str args} {
    $w tag remove __highlight 1.0 end
    array set opts {
	-nocase	0
	-regexp	0
	-tag	__highlight
	-color	yellow
    }
    set args [get_opts opts $args {-nocase 0 -regexp 0 -tag 1 -color 1}]
    if {[string match {} $str]} return
    set pass {}
    if {$opts(-nocase)} { append pass "-nocase " }
    if {$opts(-regexp)} { append pass "-regexp " }
    $w tag configure $opts(-tag) -background $opts(-color)
    $w mark set $opts(-tag) 1.0
    while {[string compare {} [set ix [eval $w search $pass -count numc -- \
	    [list $str] $opts(-tag) end]]]} {
	$w tag add $opts(-tag) $ix ${ix}+${numc}c
	$w mark set $opts(-tag) ${ix}+1c
    }
    catch {$w see $opts(-tag).first}
    return [expr {[llength [$w tag ranges $opts(-tag)]]/2}]
}


# best_match --
#   finds the best unique match in a list of names
#   The extra $e in this argument allows us to limit the innermost loop a
#   little further.
# Arguments:
#   l		list to find best unique match in
#   e		currently best known unique match
# Returns:
#   longest unique match in the list
#
;proc best_match {l {e {}}} {
    set ec [lindex $l 0]
    if {[llength $l]>1} {
	set e  [string length $e]; incr e -1
	set ei [string length $ec]; incr ei -1
	foreach l $l {
	    while {$ei>=$e && [string first $ec $l]} {
		set ec [string range $ec 0 [incr ei -1]]
	    }
	}
    }
    return $ec
}

# getrandfile --
#
#   returns a random line from a file
#
# Arguments:
#   file	filename to get line from
# Results:
#   Returns a line as a string
#
;proc getrandfile {file} {
    set fid [open $file]
    set data [split [read $fid] \n]
    close $fid
    return [lindex $data [randrng [llength $data]]]
}

# randrng --
#   gets random number within input range
# Arguments:
#   rng		range to limit output to
# Returns:
#   returns random number within range 0..$rng
;proc randrng {rng} {
    return [expr {int($rng * rand())}]
}

# grep --
#   cheap grep routine
# Arguments:
#   exp		regular expression to look for
#   args	files to search in
# Returns:
#   list of lines that in files that matched $exp
#
;proc grep {exp args} {
    if 0 {
	## To be implemented
	-count -nocase -number -names -reverse -exact
    }
    if {[string match {} $args]} return
    set output {}
    foreach file [eval glob $args] {
	set fid [open $file]
	foreach line [split [read $fid] \n] {
	    if {[regexp $exp $line]} { lappend output $line }
	}
	close $fid
    }
    return $output
}

# line_append --
#   appends a string to the end of every line of data from a file
# Arguments:
#   file	file to get data from
#   stuff	stuff to append to each line
# Returns:
#   file data with stuff appended to each line
#
;proc line_append {file stuff} {
    set fid [open $file]
    set data [read $fid]
    catch {close $fid}
    return [join [split $data \n] $stuff\n]
}


# alias --
#   akin to the csh alias command
# Arguments:
#   newcmd	(optional) command to bind alias to
#   args	command and args being aliased
# Returns:
#   If called with no args, then it dumps out all current aliases
#   If called with one arg, returns the alias of that arg (or {} if none)
#
;proc alias {{newcmd {}} args} {
    if {[string match {} $newcmd]} {
	set res {}
	foreach a [interp aliases] {
	    lappend res [list $a -> [interp alias {} $a]]
	}
	return [join $res \n]
    } elseif {[string match {} $args]} {
	interp alias {} $newcmd
    } else {
	eval interp alias [list {} $newcmd {}] $args
    }
}

# echo --
#   Relaxes the one string restriction of 'puts'
# Arguments:
#   args	any number of strings to output to stdout
# Returns:
#   Outputs all input to stdout
#
;proc echo args { puts [concat $args] }

# which --
#   tells you where a command is found
# Arguments:
#   cmd		command name
# Returns:
#   where command is found (internal / external / unknown)
#
;proc which cmd {
    ## FIX - make namespace friendly
    set lcmd [list $cmd]
    if {
	[string compare {} [uplevel info commands $lcmd]] ||
	([uplevel auto_load $lcmd] &&
	[string compare {} [uplevel info commands $lcmd]])
    } {
	set ocmd [uplevel namespace origin $lcmd]
	# First check to see if it is an alias
	# This requires two checks because interp aliases doesn't
	# canonically return fully (un)qualified names
	set aliases [interp aliases]
	if {[lsearch -exact $aliases $ocmd] > -1} {
	    set result "$cmd: aliased to \"[alias $ocmd]\""
	} elseif {[lsearch -exact $aliases $cmd] > -1} {
	    set result "$cmd: aliased to \"[alias $cmd]\""
	} elseif {[string compare {} [uplevel info procs $lcmd]] || \
		([string match ?*::* $ocmd] && \
		[string compare {} [namespace eval \
		[namespace qualifiers $ocmd] \
		[list info procs [namespace tail $ocmd]]]])} {
	    # Here we checked if the proc that has been imported before
	    # deciding it is a regular command
	    set result "$cmd: procedure $ocmd"
	} else {
	    set result "$cmd: command"
	}
	global auto_index
	if {[info exists auto_index($cmd)]} {
	    # This tells you where the command MIGHT have come from -
	    # not true if the command was redefined interactively or
	    # existed before it had to be auto_loaded.  This is just
	    # provided as a hint at where it MAY have come from
	    append result " ($auto_index($cmd))"
	}
	return $result
    } elseif {[string compare {} [auto_execok $cmd]]} {
	return [auto_execok $cmd]
    } else {
	return -code error "$cmd: command not found"
    }
}

# ls --
#   mini-ls equivalent (directory lister)
# Arguments:
#   ?-all?	list hidden files as well (Unix dot files)
#   ?-long?	list in full format "permissions size date filename"
#   ?-full?	displays / after directories and link paths for links
#   args	names/glob patterns of directories to list
# Returns:
#   a directory listing
#
interp alias {} ::Utility::dir {} namespace inscope ::Utility ls
;proc ls {args} {
    array set s {
	-all 0 -full 0 -long 0
	0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
    }
    set args [get_opts s $args [array get s -*]]
    set sep [string trim [file join . .] .]
    if {[string match {} $args]} { set args . }
    foreach arg $args {
	if {[file isdir $arg]} {
	    set arg [string trimr $arg $sep]$sep
	    if {$s(-all)} {
		lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
	    } else {
		lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
	    }
	} else {
	    lappend out [list [file dirname $arg]$sep \
		    [lsort [glob -nocomplain -- $arg]]]
	}
    }
    if {$s(-long)} {
	global tcl_platform
	set old [clock scan {1 year ago}]
	switch -exact -- $tcl_platform(os) {
	    windows	{ set fmt "%-5s %8d %s %s\n" }
	    default	{ set fmt "%s %-8s %-8s %8d %s %s\n" }
	}
	foreach o $out {
	    set d [lindex $o 0]
	    if {[llength $out]>1} { append res $d:\n }
	    foreach f [lindex $o 1] {
		file lstat $f st
		array set st [file attrib $f]
		set f [file tail $f]
		if {$s(-full)} {
		    switch -glob $st(type) {
			dir* { append f $sep }
			link { append f " -> [file readlink $d$sep$f]" }
			fifo { append f | }
			default { if {[file exec $d$sep$f]} { append f * } }
		    }
		}
		switch -exact -- $st(type) {
		    file	{ set mode - }
		    fifo	{ set mode p }
		    default	{ set mode [string index $st(type) 0] }
		}
		set cfmt [expr {$st(mtime)>$old?{%b %d %H:%M}:{%b %d  %Y}}]
		switch -exact -- $tcl_platform(os) {
		    windows	{
			# RHSA
			append mode $st(-readonly) $st(-hidden) \
				$st(-system) $st(-archive)
			append res [format $fmt $mode $st(size) \
				[clock format $st(mtime) -format $cfmt] $f]
		    }
		    macintosh	{
			append mode $st(-readonly) $st(-hidden)
			append res [format $fmt $mode $st(-creator) \
				$st(-type) $st(size) \
				[clock format $st(mtime) -format $cfmt] $f]
		    }
		    default	{ ## Unix is our default platform type
			foreach j [split [format %o \
				[expr {$st(mode)&0777}]] {}] {
			    append mode $s($j)
			}
			append res [format $fmt $mode $st(-owner) $st(-group) \
				$st(size) \
				[clock format $st(mtime) -format $cfmt] $f]
		    }
		}
	    }
	    append res \n
	}
    } else {
	foreach o $out {
	    set d [lindex $o 0]
	    if {[llength $out]>1} { append res $d:\n }
	    set i 0
	    foreach f [lindex $o 1] {
		if {[string len [file tail $f]] > $i} {
		    set i [string len [file tail $f]]
		}
	    }
	    set i [expr {$i+2+$s(-full)}]
	    ## Assume we have at least 70 char cols
	    set j [expr {70/$i}]
	    set k 0
	    foreach f [lindex $o 1] {
		set f [file tail $f]
		if {$s(-full)} {
		    switch -glob [file type $d$sep$f] {
			d* { append f $sep }
			l* { append f @ }
			default { if {[file exec $d$sep$f]} { append f * } }
		    }
		}
		append res [format "%-${i}s" $f]
		if {[incr k]%$j == 0} {set res [string trimr $res]\n}
	    }
	    append res \n\n
	}
    }
    return [string trimr $res]
}

# fit_format --
# This procedure attempts to format a value into a particular format string.
#
# Arguments:
# format	- The format to fit
# val		- The value to be validated
#
# Returns:	0 or 1 (whether it fits the format or not)
#
# Switches:
# -fill ?var?	- Default values will be placed to fill format to spec
#		  and the resulting value will be placed in variable 'var'.
#		  It will equal {} if the match invalid
#		  (doesn't work all that great currently)
# -best ?var?	- 'Fixes' value to fit format, placing best correct value
#		  in variable 'var'.  If current value is ok, the 'var'
#		  will equal it, otherwise it removes chars from the end
#		  until it fits the format, then adds any fixed format
#		  chars to value.  Can be slow (recursive tkFormat op).
# -strict	- Value must be an exact match for format (format && length)
# --		- End of switches

;proc fit_format {args} {
    set fill {}; set strict 0; set best {}; set result 1;
    set name [lindex [info level 0] 0]
    while {[string match {-*} [lindex $args 0]]} {
	switch -- [string index [lindex $args 0] 1] {
	    b {
		set best [lindex $args 1]
		set args [lreplace $args 0 1]
	    }
	    f {
		set fill [lindex $args 1]
		set args [lreplace $args 0 1]
	    }
	    s {
		set strict 1
		set args [lreplace $args 0 0]
	    }
	    - {
		set args [lreplace $args 0 0]
		break
	    }
	    default {
		return -code error "bad $name option \"[lindex $args 0]\",\
			must be: -best, -fill, -strict, or --"
	    }
	}
    }

    if {[llength $args] != 2} {
	return -code error "wrong \# args: should be \"$name ?-best varname?\
		?-fill varname? ?-strict? ?--? format value\""
    }
    set format [lindex $args 0]
    set val    [lindex $args 1]

    set flen [string length $format]
    set slen [string length $val]
    if {$slen > $flen} {set result 0}
    if {$strict} { if {$slen != $flen} {set result 0} }

    if {$result} {
	set regform {}
	foreach c [split $format {}] {
	    set special 0
	    if {[string match {[0AaWzZ]} $c]} {
		set special 1
		switch $c {
		    0	{set fmt {[0-9]}}
		    A	{set fmt {[A-Z]}}
		    a	{set fmt {[a-z]}}
		    W	{set fmt "\[ \t\r\n\]"}
		    z	{set fmt {[A-Za-z]}}
		    Z	{set fmt {[A-Za-z0-9]}}
		}
	    } else {
		set fmt $c
	    }

	}
	echo $regform $format $val
	set result [string match $regform $val]
    }

    if [string compare $fill {}] {
	upvar $fill fvar
	if {$result} {
	    set fvar $val[string range $format $i end]
	} else {
	    set fvar {}
	}
    }

    if [string compare $best {}] {
	upvar $best bvar
	set bvar $val
	set len [string length $bvar]
	if {!$result} {
	    incr len -2
	    set bvar [string range $bvar 0 $len]
	    # Remove characters until it's in valid format
	    while {$len > 0 && ![tkFormat $format $bvar]} {
		set bvar [string range $bvar 0 [incr len -1]]
	    }
	    # Add back characters that are fixed
	    while {($len<$flen) && ![string match \
		    {[0AaWzZ]} [string index $format [incr len]]]} {
		append bvar [string index $format $len]
	    }
	} else {
	    # If it's already valid, at least we can add fixed characters
	    while {($len<$flen) && ![string match \
		    {[0AaWzZ]} [string index $format $len]]} {
		append bvar [string index $format $len]
		incr len
	    }
	}
    }

    return $result
}


# validate --
# This procedure validates particular types of numbers/formats
#
# Arguments:
# type		- The type of validation (alphabetic, alphanumeric, date,
#		hex, integer, numeric, real).  Date is always strict.
# val		- The value to be validated
#
# Returns:	0 or 1 (whether or not it resembles the type)
#
# Switches:
# -incomplete	enable less precise (strict) pattern matching on number
#		useful for when the number might be half-entered
#
# Example use:	validate real 55e-5
#		validate -incomplete integer -505
#

;proc validate {args} {
    if {[string match [lindex $args 0]* "-incomplete"]} {
	set strict 0
	set opt *
	set args [lreplace $args 0 0]
    } else {
	set strict 1
	set opt +
    }

    if {[llength $args] != 2} {
	return -code error "wrong \# args: should be\
		\"[lindex [info level 0] 0] ?-incomplete? type value\""
    } else {
	set type [lindex $args 0]
	set val  [lindex $args 1]
    }

    ## This is a big switch for speed reasons
    switch -glob -- $type {
	alphab*	{ # alphabetic
	    return [regexp -nocase "^\[a-z\]$opt\$" $val]
	}
	alphan* { # alphanumeric
	    return [regexp -nocase "^\[a-z0-9\]$opt\$" $val]
	}
	b*	{ # boolean - would be nice if it were more than 0/1
	    return [regexp "^\[01\]$opt\$" $val]
	}
	d*	{ # date - always strict
	    return [expr {![catch {clock scan $val}]}]
	}
	h*	{ # hexadecimal
	    return [regexp -nocase "^(0x)?\[0-9a-f\]$opt\$" $val]
	}
	i*	{ # integer
	    return [regexp "^\[-+\]?\[0-9\]$opt\$" $val]
	}
	n*	{ # numeric
	    return [regexp "^\[0-9\]$opt\$" $val]
	}
	rea*	{ # real
	    return [regexp -nocase [expr {$strict
	    ?{^[-+]?([0-9]+\.?[0-9]*|[0-9]*\.?[0-9]+)(e[-+]?[0-9]+)?$}
	    :{^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}}] $val]
	}
	reg*	{ # regexp
	    return [expr {![catch {regexp $val {}}]}]
	}
	val*	{ # value
	    return [expr {![catch {expr {1*$val}}]}]
	}
	l*	{ # list
	    return [expr {![catch {llength $val}]}]
	}
	w*	{ # widget
	    return [winfo exists $val]
	}
	default {
	    return -code error "bad [lindex [info level 0] 0] type \"$type\":\
		    \nmust be [join [lsort {alphabetic alphanumeric date \
		    hexadecimal integer numeric real value \
		    list boolean}] {, }]"
	}
    }
    return
}

# allow_null_elements --
#
#   Sets up a read trace on an array to allow reading any value
#   and ensure that some default exists
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
;proc allow_null_elements {array {default {}}} {
    uplevel 1 [list trace variable $array r [list \
	    [namespace code ensure_default] $default]]
}

;proc ensure_default {val array idx op} {
    upvar $array var
    if {[array exists var]} {
	if {![info exists var($idx)]} {
	    set var($idx) $val
	}
    } elseif {![info exists var]} {
	set var $val
    }
}

# deny_null_elements --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
;proc deny_null_elements {array {default {}}} {
    ## FIX: should use vinfo and remove any *ensure_default* read traces
    uplevel 1 [list trace vdelete $array r [list \
	    [namespace code ensure_default] $default]]
}


}; # end namespace ::Utility