CMCc Some code to map metakit views to arrays of dictionaries
namespace eval dattach {
variable debug 0
proc Write {view selector array var el op} {
upvar $var val
variable debug
if {$debug} {
puts stderr "Write: '$view' '$selector' '$array' '$var' '$el' '$op'"
puts stderr "V: $val($el)"
catch {[dict get $val($el)]} err
puts stderr "Err: $err"
}
set row [::mk::select $view $selector $el]
if {[llength $row]} {
eval ::mk::set ${view}.$row [dict get $val($el)] $selector $el
} else {
eval ::mk::row append $view [dict get $val($el)] $selector $el
}
}
proc Read {view selector array var el op} {
upvar $var val
variable debug
if {$debug} {
puts stderr "Read: '$view' '$selector' '$array' '$var' '$el' '$op'"
}
set row [::mk::select $view $selector $el]
if {[llength $row]} {
set val($el) [eval dict create [::mk::get ${view}.$row]]
} else {
error "dattach can't read \"${array}\(${el}\): no such element in array"
}
}
proc Unset {view selector array var el op} {
upvar $var val
variable debug
if {$debug} {
puts stderr "Unset: '$view' '$selector' '$array' '$var' '$el' '$op'"
}
if {$el == ""} {
puts stderr "Trace: unset1 $view"
::mk::loop el1 ${view} {
#catch {puts stderr "Trace: unset2 $el1 [::mk::get $el1]"}
catch {::mk::row delete $el1}
}
puts stderr "Trace: unset done"
} else {
set row [::mk::select $view $selector $el]
::mk::row delete ${view}.$row
}
}
proc attach {view array {selector ""}} {
if {$selector == ""} {
set selector [lindex [::mk::view layout $view] 0]
}
variable debug
if {$debug} {
puts stderr "dattach: $array to $view $selector"
}
upvar $array a
set a() ""
unset a()
trace add variable a unset [list ::dattach::Unset $view $selector $array ]
trace add variable a read [list ::dattach::Read $view $selector $array ]
trace add variable a write [list ::dattach::Write $view $selector $array ]
}
proc snort {view array {selector ""}} {
uplevel ::dattach::attach $view $array $selector
upvar $array a
::mk::loop el1 ${view} {
set sel [eval dict create [::mk::get $el1]]
set a([dict get $sel $selector]) $sel
}
}
namespace export attach snort
}and here are a few tests:
if {$argv0 ==
info script} {
package require Mk4tcl
#set ::dattach::debug 1
proc dumpit {heading {var shoesize}} {
puts "*** $heading"
upvar $var array
foreach last [array names array] {
if {[catch {puts "$last: $array($last)"} error]} {
puts "error on $var element $last: $error"
}
}
puts "---"
}
set db [mk::file open db /tmp/datafile.mk]
set vw [mk::view layout db.people {last first shoesize:I}]
# fill in some db rows
mk::row append $vw last "Lennon" first "John" shoesize 44
mk::row append $vw last "Gordon" first "Flash" shoesize 42
mk::row append $vw last "Hendrix" first "Jimi" shoesize 49
mk::file commit db
::dattach::attach $vw shoesize last
dumpit "attach gets rows lazily - so this will be empty"
set x $shoesize(Lennon)
set x $shoesize(Gordon)
dumpit "Fetch some attached values"
set shoesize(Cass) [dict create first Mama shoesize 40 alive n]
dumpit "Create a new Row" shoesize
dict set shoesize(Cass) last Lennon ;# note, this will have no effect
dumpit "changing the key field has no effect"
::dattach::snort $vw shoes last
dumpit "snort gets all rows in existence at creation time" shoes
dict set shoes(Lennon) shoesize -1
dumpit "changing a different attached variable has an effect on all" shoes
# note - we take the first match on key
::dattach::snort $vw size shoesize
dumpit "By Shoesize" size
dict set shoesize(Cass) shoesize 44
dumpit "array names can get out of sync on snorted arrays\n*** Note: this could be fixed, if trace array was." size}
