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