1# -*- tcl -*- 2# Metakit backend for tie 3# 4# (C) 2005 Colin McCormack. 5# Taken from http://wiki.tcl.tk/13716, with permission. 6# 7# CMcC 20050303 - a backend for the tie tcllib package. Persists an 8# array in a metakit database. In conjunction with the 9# "remote" array backend, this might have similar 10# functionality to Tequila. 11 12# Modified AK 2005-09-12 13 14package require Mk4tcl 15package require tie 16package require snit 17 18snit::type mktie { 19 option -var "" ; # variable name in metakit 20 option -vtype S ; # set the variable value type 21 option -layout {} ; # additional layout elements 22 23 constructor {args} { 24 $self configurelist $args 25 26 if {$options(-var) eq ""} { 27 # no variable name supplied - use the caller's name 28 upvar 3 avar rv ;# skip some snit nesting 29 #puts stderr "using $rv" 30 set options(-var) $rv 31 } 32 #puts stderr "$self - [array get options]" 33 set layout [concat [list name text:$options(-vtype)] $options(-layout)] 34 mk::view layout tqs.$options(-var) $layout 35 } 36 37 # return a list containing the names of all keys found in the 38 # metakit database. 39 40 method names {} { 41 mk::loop c tqs.$options(-var) { 42 lappend result [mk::get $c name] 43 } 44 } 45 46 # return an integer number specifying the number of keys found in 47 # the metakit database. 48 49 method size {} { 50 return [mk::view size tqs.$options(-var)] 51 } 52 53 # return a dictionary containing the data found in the metakit 54 # database. 55 56 method get {} { 57 set dict [dict create] 58 mk::loop c tqs.$options(-var) { 59 set val [mk::get $c name text] 60 #puts stderr "get $options(-var)(\#$c) - $val" 61 dict set dict {*}$val 62 } 63 return $dict 64 } 65 66 # takes a dictionary and adds its contents to the metakit 67 68 method set {dict} { 69 dict for {key value} $dict { 70 $self setv $key $value 71 } 72 } 73 74 # removes all elements whose keys match pattern 75 76 method unset {pattern} { 77 set matches [mk::select tqs.$options(-var) -glob name $pattern] 78 foreach n [lsort -integer -decreasing $matches] { 79 mk::row delete tqs.$options(-var)!$n 80 } 81 } 82 83 # save value under key 84 85 method setv {key value} { 86 set n [mk::select tqs.$options(-var) name $key] 87 if {[llength $n] == 0} { 88 set n [mk::view size tqs.$options(-var)] 89 } elseif {[mk::get tqs.$options(-var)!$n text] == $value} { 90 return ; # no change, ignore 91 } 92 #puts stderr "set $options(-var)($key) to $value / $n" 93 mk::set tqs.$options(-var)!$n name $key text $value 94 } 95 96 # remove the value under key 97 98 method unsetv {key} { 99 set n [mk::select tqs.$options(-var) name $key] 100 if {[llength $n] == 0} { 101 error "can't unset \"$options(-var)($key)\": no such element in array" 102 return 103 } 104 mk::row delete tqs.$options(-var)!$n 105 } 106 107 # return the value for key 108 109 method getv {key} { 110 set n [mk::select tqs.$options(-var) name $key] 111 if {[llength $n] == 0} { 112 error "can't read \"$options(-var)($key)\": no such element in array" 113 return 114 } 115 return [mk::get tqs.$options(-var)!$n text] 116 } 117} 118 119mk::file open tqs tie.dat -nocommit 120::tie::register ::mktie as metakit 121 122package provide mktie 1.0 123 124# ### ### ### ######### ######### ######### 125 126if {[info script] eq $argv0} { 127 unset -nocomplain av 128 array set av {} 129 130 tie::tie av metakit 131 set av(x) blah 132 array set av {a 1 b 2 c 3 z 26} 133 ::tie::untie av 134 135 puts "second pass" 136 unset av 137 array set av {} 138 tie::tie av metakit 139 puts [array size av] 140 puts [array get av] 141} 142