Updated 2017-11-21 19:01:19 by dbohdan ▲

CMcC 20050303 - 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 {*}$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]
 }

Category Interprocess CommunicationCategory MetakitCategory Package