CMcC20050303 - a backend for the tie tcllib package. Persists an array in a metakit.
In conjunction with the remote array backend, this might have similar functionality to tequila
package provide mktie 1.0
package require Mk4tcl
package require tie
package require snit
snit::type mktie {
option -var "" ;# variable name in metakit
option -vtype S ;# set the variable value type
option -layout {} ;# additional layout elements
constructor {args} {
foreach {name val} [::cmdline::getKnownOptions args [subst {
{var.arg [list $options(-var)]
"variable name"}
{vtype.arg [list $options(-vtype)]
"variable type"}
{layout.arg [list $options(-layout)]
"addiditional elements of metakit layout"}
}]] {
set options(-$name) $val
}
if {$options(-var) eq ""} {
# no variable name supplied - use the caller's name
upvar 3 avar rv ;# skip some snit nesting
#puts stderr "using $rv"
set options(-var) $rv
}
#puts stderr "$self - [array get options]"
set layout [concat [list name text:$options(-vtype)] $options(-layout)]
mk::view layout tqs.$options(-var) $layout
}
# return a list containing the names of all keys found in the metakit
method names {} {
mk::loop c tqs.$options(-var) {
lappend result [mk::get $c name]
}
}
# return an integer number specifying the number of keys found in the metakit
method size {} {
return [mk::view size tqs.$options(-var)]
}
# return a dictionary containing the data found in the metakit
method get {} {
set dict [dict create]
mk::loop c tqs.$options(-var) {
set val [mk::get $c name text]
#puts stderr "get $options(-var)(\#$c) - $val"
dict set dict {expand}$val
}
return $dict
}
# takes a dictionary and adds its contents to the metakit
method set {dict} {
dict for {key value} $dict {
$self setv $key $value
}
}
# removes all elements whose keys match pattern
method unset {pattern} {
set matches [mk::select tqs.$options(-var) -glob name $pattern]
foreach n [lsort -integer -decreasing $matches] {
mk::row delete tqs.$options(-var)!$n
}
}
# save value under key
method setv {key value} {
set n [mk::select tqs.$options(-var) name $key]
if {[llength $n] == 0} {
set n [mk::view size tqs.$options(-var)]
} elseif {[mk::get tqs.$options(-var)!$n text] == $value} {
return ;# no change, ignore
}
#puts stderr "set $options(-var)($key) to $value / $n"
mk::set tqs.$options(-var)!$n name $key text $value
}
# remove the value under key
method unsetv {key} {
set n [mk::select tqs.$options(-var) name $key]
if {[llength $n] == 0} {
error "can't unset \"$options(-var)($key)\": no such element in array"
return
}
mk::row delete tqs.$options(-var)!$n
}
# return the value for key
method getv {key} {
set n [mk::select tqs.$options(-var) name $key]
if {[llength $n] == 0} {
error "can't read \"$options(-var)($key)\": no such element in array"
return
}
return [mk::get tqs.$options(-var)!$n text]
}
}
mk::file open tqs tie.dat -nocommit
::tie::register ::mktie as metakit
if {[info script] eq $argv0} {
unset -nocomplain av
array set av {}
tie::tie av metakit
set av(x) blah
array set av {a 1 b 2 c 3 z 26}
::tie::untie av
puts "second pass"
unset av
array set av {}
tie::tie av metakit
puts [array size av]
puts [array get av]
}