diff options
Diffstat (limited to 'tcllib/support/devel/sak/registry')
| -rw-r--r-- | tcllib/support/devel/sak/registry/pkgIndex.tcl | 2 | ||||
| -rw-r--r-- | tcllib/support/devel/sak/registry/registry.man | 171 | ||||
| -rw-r--r-- | tcllib/support/devel/sak/registry/registry.tcl | 287 | ||||
| -rw-r--r-- | tcllib/support/devel/sak/registry/registry.test | 450 |
4 files changed, 910 insertions, 0 deletions
diff --git a/tcllib/support/devel/sak/registry/pkgIndex.tcl b/tcllib/support/devel/sak/registry/pkgIndex.tcl new file mode 100644 index 0000000..0e6116b --- /dev/null +++ b/tcllib/support/devel/sak/registry/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 8.3]} return +package ifneeded pregistry 0.1 [list source [file join $dir registry.tcl]] diff --git a/tcllib/support/devel/sak/registry/registry.man b/tcllib/support/devel/sak/registry/registry.man new file mode 100644 index 0000000..d895164 --- /dev/null +++ b/tcllib/support/devel/sak/registry/registry.man @@ -0,0 +1,171 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin pregistry n 0.1] +[copyright {2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[moddesc {Registry like data store}] +[titledesc {Registry like data store}] +[require Tcl 8.3] +[require pregistry [opt 0.1]] +[description] +[para] + +This package provides a class for the creation of registry-like data +storage objects. The contents of each storage are organized in a tree, +with each node managing a set of children and attributes, each +possibly empty. Stores are not persistent by default, but can be made +so through configuring them with a tie backend to talk to. + + +[section {Class API}] + +The package exports a single command, the class command, enabling the +creation of registry instances. Its API is: + +[list_begin definitions] + +[call [cmd ::pregistry] [arg object] [arg options]...] + +This command creates a new registry object with the name [arg object], +initializes it, and returns the fully qualified name of the object +command as its result. + +[para] + +The recognized options are explained in section [sectref OPTIONS]. + +[list_end] + +[section {Object API}] + +The objects created by the class command provide the methods listed below: + +[list_begin definitions] +[call [arg object] [method delete] [arg key] [opt [arg attr]]] + +If the optional [arg attr] argument is present, the specified +attribute under [arg key] will be deleted from the object. + +If the optional [arg attr] is omitted, the specified [arg key] and any +subkeys or attributes beneath it in the hierarchy will be deleted. If +the key could not be deleted then an error is generated. If the key +did not exist, the command has no effect. + +The command returns the empty string as its result. + + +[call [arg object] [method mtime] [arg key] [opt [arg attr]]] + +If the optional [arg attr] argument is present, the time of the last +modification of the specified attribute under [arg key] will be +returned, in seconds since the epoch. + +If the optional [arg attr] is omitted, the time of the last +modification of the specified [arg key] will be returned. + +If the key did not exist, the command will generate an error. + + +[call [arg object] [method exists] [arg key] [opt [arg attr]]] + +If the optional [arg attr] argument is present, the method checks +whether the specified attribute under [arg key] is present or not. + +If the optional [arg attr] is omitted, the method checks whether the +specified [arg key] is present or not. + +In both cases the result returned is boolean value, [const True] if +the checked entity exists, and [const False] otherwise. + + +[call [arg object] [method get] [arg key] [arg attr]] + +Returns the data associated with the attribute [arg attr] under the +[arg key]. If either the key or the attribute does not exist, then an +error is generated. + + +[call [arg object] [method get||default] [arg key] [arg attr] [arg default]] + +Like method [method get], except that the [arg default] is returned if +either the key or the attribute does not exist, instead of generating +an error. + + +[call [arg object] [method keys] [arg key] [opt [arg pattern]]] + +If [arg pattern] isn't specified, the command returns a list of names +of all the subkeys of [arg key]. If [arg pattern] is specified, only +those names matching the pattern are returned. Matching is determined +using the same rules as for [cmd {string match}]. If the specified +[arg key] does not exist, then an error is generated. + + +[call [arg object] [method set] [arg key] [opt "[arg attr] [arg value]"]] + +If [arg attr] isn't specified, creates the [arg key] if it doesn't +already exist. If [arg attr] is specified, creates the [arg key] +keyName and attribute [arg attr] if necessary. + +The contents of [arg attr] are set to [arg value]. The command returns +the [arg value] as its result. + + +[call [arg object] [method attrs] [arg key] [opt [arg pattern]]] + +If [arg pattern] isn't specified, returns a list of names of all the +attributes of [arg key]. If [arg pattern] is specified, only those +names matching the pattern are returned. Matching is determined using +the same rules as for [cmd {string match}]. + + + +[call [arg object] [method configure]] + +Returns a dictionary mapping the option of the object to their +currently configured values. + +[call [arg object] [method configure] [arg option] [arg newvalue]...] + +This invokation sets the configured value of option [arg option] to +[arg newvalue]. Nothing will be done if current and new value are +identical. Returns the empty string. + +[call [arg object] [method configure] [arg option]] +[call [arg object] [method cget] [arg option]] + +Returns the value configured for the specified option [arg option]. + +[list_end] + + +[section KEYS] + +All elements in the registry are identified by a unique key, which is +a list of strings. This identifies the path from the root of the tree +to the requested element. The root itself is identified by the empty +list. Each child C of an element E have to have unique name, which +will be the last element of the key identifying this child. The head +of the key will be the key of E. + + +[section OPTIONS] + +The registry object recognize a single option, + +[list_begin options] +[opt_def -tie tiedefinition] + +See the documentation of command [cmd ::tie::tie], in the package +[package tie]. The value of the option is a list of words equivalent +to the arguments "[arg dstype] [arg dsname]..." of [cmd ::tie::tie]. +I.e. the identity of the tie backend to use, followed by the +specification of the location to use, per the chosen backend. + +Example: +[example { + set r [pregistry %AUTO% -tie [list file $path]] +}] + +[list_end] + +[keywords registry {data store} tree] +[manpage_end] diff --git a/tcllib/support/devel/sak/registry/registry.tcl b/tcllib/support/devel/sak/registry/registry.tcl new file mode 100644 index 0000000..2fc4639 --- /dev/null +++ b/tcllib/support/devel/sak/registry/registry.tcl @@ -0,0 +1,287 @@ +# -*- tcl -*- +# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +package require Tcl 8.3 +package require snit +package require tie + +# ### + +snit::type pregistry { + + # API + # delete key ?attribute? + # mtime key ?attribute? + # get key attribute + # keys key ?pattern?/* + # set key ?attribute value? + # attrs key ?pattern? + + option -tie -default {} -configuremethod TIE ; # Persistence + + constructor {args} { + $self configurelist $args + $self INIT + return + } + + # ### + + method delete {key args} { + #puts DEL|$key| + + if {[llength $args] > 1} {return -code error "wrong\#args"} + + if {[catch {NODE $key} n]} return + if {[llength $args]} { + # Delete attribute + + set attr [lindex $args 0] + set pattern [list A $n $attr *] + set km [list N $n M] + + array unset data $pattern + set data($km) [clock seconds] + } else { + # Delete key and children. + #puts N|$n| + + if {![llength $key]} { + return -code error "cannot delete root" + } + + # Children first + foreach c [array names data [list C $n *]] { + set c [lindex $c end] + #puts _|$c| + $self delete [linsert $key end $c] + } + + # And now the node itself. Modify the parent as well, + # remove this node as a child. + + set self [lindex $key end] + set pidx [list N $n P] + set npat [list N $n *] + set apat [list A $n * *] + + set pid $data($pidx) + set cidx [list C $pid $self] + set midx [list N $pid M] + + array unset data $apat + array unset data $npat + unset -nocomplain data($cidx) + set data($midx) [clock seconds] + + unset -nocomplain ncache($key) + } + return + } + + method mtime {key args} { + if {[llength $args] > 1} {return -code error "wrong\#args"} + set n [NODE $key] + if {[llength $args]} { + set attr [lindex $args 0] + set idx [list A $n $attr M] + if {![info exists data($idx)]} { + return -code error "Unknown attribute \"$attr\" in key \"$key\"" + } + } else { + set idx [list N $n M] + } + return $data($idx) + } + + method exists {key args} { + if {[llength $args] > 1} { + return -code error "wrong\#args" + } elseif {[catch {NODE $key} n]} { + return 0 + } elseif {![llength $args]} { + return 1 + } + + set attr [lindex $args 0] + set idx [list A $n $attr V] + return [info exist data($idx)] + } + + method get {key attr} { + set n [NODE $key] + set idx [list A $n $attr V] + if {![info exists data($idx)]} { + return -code error "Unknown attribute \"$attr\" in key \"$key\"" + } + return $data($idx) + } + + method get||default {key attr default} { + if {[catch {NODE $key} n]} { + return $default + } + set idx [list A $n $attr V] + if {![info exists data($idx)]} { + return $default + } + return $data($idx) + } + + method keys {key {pattern *}} { + set n [NODE $key] + set pattern [list C $n $pattern] + set res {} + foreach c [array names data $pattern] { + lappend res [linsert $key end $c] + } + return $res + } + + method attrs {key {pattern *}} { + set n [NODE $key] + set pattern [list A $n $pattern V] + set res {} + foreach c [array names data $pattern] { + lappend res [lindex $c end-1] + } + return $res + } + + method lappend {key attr value} { + set list [$self get||default $key $attr {}] + lappend list $value + $self set $key $attr $list + return + } + + method set {key args} { + set n [NODE $key 1] + if {![llength $args]} return + if {[llength $args] != 2} {return -code error "wrong\#args"} + foreach {attr value} $args break + + # Ignore calls which do not change the contents of the + # database. + + set aidx [list A $n $attr V] + if { + [info exists data($aidx)] && + [string equal $data($aidx) $value] + } return ; # {} + + #puts stderr "$n $attr | $key | ($value)" + + set aids [list A $n $attr M] + set data($aidx) $value + set data($aids) [clock seconds] + return + } + + # ### state + + variable data -array {} + + # Tree of keys. Each keys can have multiple attributes. + # Each key, and attribute, have a modification timestamp. + + # Each node in the tree is identified by a numeric id. Children + # refer to their parents. Parent id + name refers to unique child. + + # Array contents + + # (I) -> number id counter + # (C id name) -> id parent id x name => child id + # (N id P) -> id node id => parent id, empty for root + # (N id M) -> timestamp node id => last modification + # (A id name V) -> string node id x attribute name => value + # (A id name M) -> timestamp s.a => last modification + + # This structure is less memory/space intensive than the setup of + # 1registry. It is also more difficult to query as it is less + # tabular, less redundant. + + # Another thing becoming more complex is the deletion of a + # subtree. It is now necessary to walk the the tree, instead of + # just deleting all keys in the array matching a certain + # pattern. That at least can be done at the C level (array unset). + + # The conversion from key list to node is also linear in key + # length, and an operation done often. Better cache it. However + # only internally, or the space savingsare gone too as the space + # is then taken by the conversion cache. Hm. Still less than + # before, as each key is listed at most once. In 1registry it was + # repeated for each of its attributes as well. This would regain + # speed for searches, as the conversion cache now is a tabular + # representation of the tree, and easily globbed. + + # ### configure -tie (persistence) + + method TIE {option value} { + if {[string equal $options(-tie) $value]} return + tie::untie [myvar data] + # 8.5 - tie::tie [myvar data] {expand}$value + eval [linsert $value 0 tie::tie [myvar data]] + set options(-tie) $value + return + } + + method INIT {} { + if {![info exists data(I)]} { + set anchor {C {} {}} + set rootp {N 0 P} + set roots {N 0 M} + + set data(I) 0 + set data($anchor) 0 + set data($rootp) {} + set data($roots) [clock seconds] + } + return + } + + variable ncache -array {} + + proc NODE {key {create 0}} { + upvar 1 ncache ncache data data + if {[info exist ncache($key)]} { + # Cached, shortcut + return $ncache($key) + } + if {![llength $key]} { + # Root, shortcut + set id 0 + } else { + # Recursively convert, possibly create + set parent [lrange $key 0 end-1] + set self [lindex $key end] + set pid [NODE $parent $create] + set idx [list C $pid $self] + + if {[info exists data($idx)]} { + set id $data($idx) + } elseif {!$create} { + return -code error "Unknown key \"$key\"" + } else { + set id [incr data(I)] + set idxp [list N $id P] + set idxm [list N $id M] + + set data($idx) $id + set data($idxp) $pid + set data($idxm) [clock seconds] + } + } + set ncache($key) $id + return $id + } + + # ### +} + +## +# ### + +package provide pregistry 0.1 diff --git a/tcllib/support/devel/sak/registry/registry.test b/tcllib/support/devel/sak/registry/registry.test new file mode 100644 index 0000000..4dead0c --- /dev/null +++ b/tcllib/support/devel/sak/registry/registry.test @@ -0,0 +1,450 @@ +# -*- tcl -*- +# registry.test: tests for the registry structure. +# +# Copyright (c) 2006 by Andreas Kupries <a.kupries@westend.com> +# All rights reserved. +# +# RCS: @(#) $Id: registry.test,v 1.1 2006/09/06 06:07:09 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.3 +testsNeedTcltest 2.2 + +support { + use snit/snit.tcl snit + use tie/tie.tcl tie +} +testing { + useLocal registry.tcl pregistry +} + +# ------------------------------------------------------------------------- + +proc dump/ {r {root {}} {rv {}}} { + if {$rv != {}} {upvar 1 $rv res} else {set res {}} + lappend res $root/ + foreach a [$r attrs $root] { + lappend res [list $root/ :$a [$r get $root $a]] + } + foreach c [$r keys $root] { + dump/ $r $c res + } + return $res +} + +proc dump {r root} { + lappend res $root/ + foreach a [$r attrs $root] { + lappend res [list $root/ :$a [$r get $root $a]] + } + return $res +} + +# ------------------------------------------------------------------------- + +test registry-1.0 {base state} { + pregistry myreg + set res [dump/ myreg] + myreg destroy + set res +} / + +# ------------------------------------------------------------------------- +# Attribute manipulation, root, in-tree, and leaf + +set n 0 +foreach {key prekey structure} { + {} {} / + {sub tree leaf} {} {/ sub/ {sub tree/} {sub tree leaf/}} + {sub tree} {sub tree leaf} {/ sub/ {sub tree/} {sub tree leaf/}} +} { + test registry-2.$n {structure} { + pregistry myreg + myreg set $prekey + myreg set $key + set res [dump/ myreg] + myreg destroy + set res + } $structure + + test registry-3.1.$n {no attributes, node creation} { + pregistry myreg + myreg set $prekey + myreg set $key + set res [dump myreg $key] + myreg destroy + set res + } [list $key/] + + test registry-3.2.$n {bad node creation} { + pregistry myreg + catch {myreg set} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodset type selfns win self key args"} + + test registry-3.3.$n {bad node creation} { + pregistry myreg + catch {myreg set a b c d} res + myreg destroy + set res + } {wrong#args} + + test registry-3.4.$n {bad node creation} { + pregistry myreg + catch {myreg set a b} res + myreg destroy + set res + } {wrong#args} + + test registry-4.1.$n {set attribute, ok} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [dump myreg $key] + myreg destroy + set res + } [list $key/ [list $key/ :foo bar]] + + test registry-4.2.$n {set attribute, change} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg get $key foo] + myreg set $key foo bold + lappend res [myreg get $key foo] + myreg destroy + set res + } {bar bold} + + test registry-5.1.$n {get attribute, ok} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg get $key foo] + myreg destroy + set res + } bar + + test registry-5.2.$n {get attribute, missing attribute} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get $key alpha} res + myreg destroy + set res + } "Unknown attribute \"alpha\" in key \"$key\"" + + test registry-5.3.$n {get attribute, missing key} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get TEST x} res + myreg destroy + set res + } {Unknown key "TEST"} + + test registry-5.4.$n {get attribute, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodget type selfns win self key attr"} + + test registry-5.5.$n {get attribute, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get x} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodget type selfns win self key attr"} + + test registry-5.6.$n {get attribute, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get x y z} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodget type selfns win self key attr"} + + test registry-6.1.$n {get||default, ok} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg get||default $key foo DEF] + myreg destroy + set res + } bar + + test registry-6.2.$n {get||default, missing attribute} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg get||default $key alpha DEF] + myreg destroy + set res + } DEF + + test registry-6.3.$n {get||default, missing key} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg get||default TEST x DEF] + myreg destroy + set res + } DEF + + test registry-6.4.$n {get||default, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get||default} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"} + + test registry-6.5.$n {get||default, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get||default x} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"} + + test registry-6.6.$n {get||default, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get||default x y} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"} + + test registry-6.7.$n {get||default, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg get||default x y z a} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"} + + test registry-7.1.$n {attribute matching, total} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + myreg set $key alpha omega + set res [lsort [myreg attrs $key]] + myreg destroy + set res + } {alpha foo} + + test registry-7.2.$n {attribute matching, partial} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + myreg set $key alpha omega + set res [lsort [myreg attrs $key a*]] + myreg destroy + set res + } alpha + + test registry-7.3.$n {attribute matching, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg attrs} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodattrs type selfns win self key ?pattern?"} + + test registry-7.4.$n {attribute matching, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg attrs x y z} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodattrs type selfns win self key ?pattern?"} + + test registry-8.1.$n {attribute existence, ok} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg exists $key foo] + myreg destroy + set res + } 1 + + test registry-8.2.$n {attribute existence, missing} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg exists $key alpha] + myreg destroy + set res + } 0 + + test registry-8.3.$n {attribute existence, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg exists} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodexists type selfns win self key args"} + + test registry-8.4.$n {attribute existence, wrong#args} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + catch {myreg exists x y z} res + myreg destroy + set res + } {wrong#args} + + test registry-9.1.$n {key existence, ok} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg exists $key] + myreg destroy + set res + } 1 + + test registry-9.2.$n {key existence, missing} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + set res [myreg exists alpha] + myreg destroy + set res + } 0 + + # key existence, wrong args, see attribute existence + + test registry-10.1.$n {key matching, total} { + pregistry myreg + myreg set $key + myreg set [linsert $key end alpha] + myreg set [linsert $key end omega] + set res [lsort [myreg keys $key]] + myreg destroy + set res + } [list [linsert $key end alpha] [linsert $key end omega]] + + test registry-10.2.$n {key matching, partial} { + pregistry myreg + myreg set $key + myreg set [linsert $key end alpha] + myreg set [linsert $key end omega] + set res [lsort [myreg keys $key a*]] + myreg destroy + set res + } [list [linsert $key end alpha]] + + test registry-10.3.$n {key matching, wrong#args} { + pregistry myreg + myreg set $key + catch {myreg keys} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodkeys type selfns win self key ?pattern?"} + + test registry-10.4.$n {key matching, wrong#args} { + pregistry myreg + myreg set $key + catch {myreg keys x y z} res + myreg destroy + set res + } {wrong # args: should be "::pregistry::Snit_methodkeys type selfns win self key ?pattern?"} + + test registry-11.1.$n {attribute deletion, ok} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + myreg set $key alpha omega + myreg delete $key foo + set res [dump myreg $key] + myreg destroy + set res + } [list $key/ [list $key/ :alpha omega]] + + test registry-11.2.$n {attribute deletion, missing} { + pregistry myreg + myreg set $prekey + myreg set $key foo bar + myreg set $key alpha omega + set code [catch {myreg delete $key fox} res] + myreg destroy + list $code $res + } {0 {}} + + incr n +} + +set n 0 +foreach {par key structure} { + {foo fox fool} {foo fox fool bar soom} + {{/ foo/ {foo fox/} {foo fox fool/} {foo fox fool bar/} {foo fox fool bar soom/} {{foo fox fool bar soom/} :foo bar}} {/ foo/ {foo fox/}}} + + foo foo + {{/ foo/ {foo/ :foo bar}} /} +} { + test registry-12.1.$n {deletion} { + set res {} + pregistry myreg + myreg set $par + myreg set $key foo bar + lappend res [dump/ myreg] + myreg delete $par + lappend res [dump/ myreg] + myreg destroy + set res + } $structure + + test registry-12.2.$n {deletion of non-existing key} { + pregistry myreg + myreg set $par + catch {myreg delete FOO} res + myreg destroy + set res + } {} + + incr n +} + +test registry-13.1 {deletion of root} { + pregistry myreg + catch {myreg delete {}} res + myreg destroy + set res +} {cannot delete root} + +test registry-13.2 {wrong#args} { + pregistry myreg + catch {myreg delete} res + myreg destroy + set res +} {wrong # args: should be "::pregistry::Snit_methoddelete type selfns win self key args"} + +test registry-13.3 {wrong#args} { + pregistry myreg + catch {myreg delete a b c} res + myreg destroy + set res +} {wrong#args} + +# ------------------------------------------------------------------------- + +::tcltest::cleanupTests |