summaryrefslogtreecommitdiffstats
path: root/tcllib/support/devel/sak/registry
diff options
context:
space:
mode:
Diffstat (limited to 'tcllib/support/devel/sak/registry')
-rw-r--r--tcllib/support/devel/sak/registry/pkgIndex.tcl2
-rw-r--r--tcllib/support/devel/sak/registry/registry.man171
-rw-r--r--tcllib/support/devel/sak/registry/registry.tcl287
-rw-r--r--tcllib/support/devel/sak/registry/registry.test450
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