summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2004-10-27 17:01:41 (GMT)
committerandreas_kupries <akupries@shaw.ca>2004-10-27 17:01:41 (GMT)
commitbbf8d929edc48523f1dbbb816c26ccc93a57518f (patch)
tree0f9a457f1dd68653ada42bff9e5a4217f89c11c6
parentfb0dd7d79693fa04244c19f9b0fbaed6eec65410 (diff)
downloadtcl-bbf8d929edc48523f1dbbb816c26ccc93a57518f.zip
tcl-bbf8d929edc48523f1dbbb816c26ccc93a57518f.tar.gz
tcl-bbf8d929edc48523f1dbbb816c26ccc93a57518f.tar.bz2
* tests/tm.test: Expanded on the testsuite entered by Donal.
* library/tm.tcl: Even found bugs, these have been corrected.
-rw-r--r--ChangeLog5
-rw-r--r--library/tm.tcl47
-rw-r--r--tests/tm.test200
3 files changed, 229 insertions, 23 deletions
diff --git a/ChangeLog b/ChangeLog
index a0939c6..79ae6db 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2004-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * tests/tm.test: Expanded on the testsuite entered by Donal.
+ * library/tm.tcl: Even found bugs, these have been corrected.
+
2004-10-26 Kevin Kenny <kennykb@acm.org>
* tests/format.test (format-19.1): Additional regression test for
diff --git a/library/tm.tcl b/library/tm.tcl
index cfed444..491d25d 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -98,45 +98,56 @@ proc ::tcl::tm::add {args} {
variable paths
- set newpaths {}
+ # We use a copy of the path as source during validation, and
+ # extend it as well. Because we not only have to detect if the new
+ # paths are bogus with respect to the existing paths, but also
+ # between themselves. Otherwise we can still add bogus paths, by
+ # specifying them in a single call. This makes the use of the new
+ # paths simpler as well, a trivial assignment of the collected
+ # paths to the official state var.
+
+ set newpaths $paths
foreach p $args {
- set pos [lsearch -exact $paths $p]
- if {$pos >= 0} {
+ if {$p in $newpaths} {
# Ignore a path already on the list.
continue
}
# Search for paths which are subdirectories of the new one. If
- # there are any then new path violates the restriction about
- # ancestors.
+ # there are any then the new path violates the restriction
+ # about ancestors.
- set pos [lsearch -glob $paths ${p}/*]
+ set pos [lsearch -glob $newpaths ${p}/*]
+ # Cannot use "in", we need the position for the message.
if {$pos >= 0} {
return -code error \
- "$p is ancestor of existing module path [lindex $paths $pos]."
+ "$p is ancestor of existing module path [lindex $newpaths $pos]."
}
- # Now look for paths which are ancestors of the new one. This
- # reverse question req us to loop over the existing paths :(
+ # Now look for existing paths which are ancestors of the new
+ # one. This reverse question forces us to loop over the
+ # existing paths, as each element is the pattern, not the new
+ # path :(
- foreach ep $paths {
+ foreach ep $newpaths {
if {[string match ${ep}/* $p]} {
return -code error \
"$p is subdirectory of existing module path $ep."
}
}
- lappend newpaths $p
+ set newpaths [linsert $newpaths 0 $p]
}
# The validation of the input is complete and successful, and
- # everything in newpaths is actually new. We can now extend the
- # list of paths.
+ # everything in newpaths is either an old path, or added. We can
+ # now extend the official list of paths, a simple assignment is
+ # sufficient.
- foreach p $newpaths {
- set paths [linsert $paths 0 $p]
- }
+ set paths $newpaths
+ return
}
+
proc ::tcl::tm::remove {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
#
@@ -157,6 +168,7 @@ proc ::tcl::tm::remove {args} {
}
}
}
+
proc ::tcl::tm::list {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
@@ -164,8 +176,7 @@ proc ::tcl::tm::list {args} {
return -code error "wrong # args: should be \"::tcl::tm::path list\""
}
variable paths
-
- return $paths
+ return $paths
}
# ::tcl::tm::UnknownHandler --
diff --git a/tests/tm.test b/tests/tm.test
index ada4d46..91329a2 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -6,7 +6,7 @@
# Copyright (c) 2004 by Donal K. Fellows.
# All rights reserved.
#
-# RCS: @(#) $Id: tm.test,v 1.2 2004/10/25 15:37:16 dkf Exp $
+# RCS: @(#) $Id: tm.test,v 1.3 2004/10/27 17:01:46 andreas_kupries Exp $
package require Tcl 8.5
if {"::tcltest" ni [namespace children]} {
@@ -42,11 +42,201 @@ test tm-2.3 {tm: roots command syntax} -returnCodes error -body {
::tcl::tm::roots foo bar
} -result "wrong # args: should be \"::tcl::tm::roots paths\""
-test tm-3.1 {tm: module path management} {
- # Andreas Kupries needs to write some tests here...
- error FIXME
-} {}
+test tm-3.1 {tm: module path management, input validation} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -returnCodes error -body {
+ ::tcl::tm::path add foo/bar
+ ::tcl::tm::path add foo
+} -result {foo is ancestor of existing module path foo/bar.}
+
+test tm-3.2 {tm: module path management, input validation} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -returnCodes error -body {
+ ::tcl::tm::path add foo
+ ::tcl::tm::path add foo/bar
+} -result {foo/bar is subdirectory of existing module path foo.}
+
+test tm-3.3 {tm: module path management, add/list interaction} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ ::tcl::tm::path add foo
+ ::tcl::tm::path add bar
+ ::tcl::tm::path list
+} -result {bar foo}
+
+test tm-3.4 {tm: module path management, add/list interaction} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ ::tcl::tm::path add foo bar baz
+ ::tcl::tm::path list
+} -result {baz bar foo}
+
+test tm-3.5 {tm: module path management, input validation/list interaction} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ catch {::tcl::tm::path add snarf foo geode foo/bar}
+ # Nothing is added if a problem was found.
+ ::tcl::tm::path list
+} -result {}
+
+test tm-3.6 {tm: module path management, input validation/list interaction} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ catch {::tcl::tm::path add snarf foo/bar geode foo}
+ # Nothing is added if a problem was found.
+ ::tcl::tm::path list
+} -result {}
+
+test tm-3.7 {tm: module path management, input validation/list interaction} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ catch {
+ ::tcl::tm::path add foo/bar
+ ::tcl::tm::path add snarf geode foo
+ }
+ # Nothing is added if a problem was found.
+ ::tcl::tm::path list
+} -result {foo/bar}
+
+test tm-3.8 {tm: module path management, input validation, ignore duplicates} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ # Ignore path if present
+ ::tcl::tm::path add foo
+ ::tcl::tm::path add snarf geode foo
+ ::tcl::tm::path list
+} -result {geode snarf foo}
+
+test tm-3.9 {tm: module path management, input validation, ignore duplicates} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ # Ignore path if present
+ ::tcl::tm::path add foo snarf geode foo
+ ::tcl::tm::path list
+} -result {geode snarf foo}
+
+test tm-3.10 {tm: module path management, remove} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ ::tcl::tm::path add snarf geode foo
+ ::tcl::tm::path remove foo
+ ::tcl::tm::path list
+} -result {geode snarf}
+
+test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ ::tcl::tm::path add foo snarf geode
+ ::tcl::tm::path remove fox
+ ::tcl::tm::path list
+} -result {geode snarf foo}
+
+
+proc genpaths {base} {
+ foreach {major minor} [split [info tclversion] .] break
+ set results {}
+ lappend results [file join $base site-tcl]
+ set base [file join $base tcl$major]
+ for {set i 0} {$i <= $minor} {incr i} {
+ lappend results [file join $base ${major}.$i]
+ }
+ return $results
+}
+
+test tm-3.12 {tm: module path management, roots} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ ::tcl::tm::roots /FOO
+ ::tcl::tm::path list
+} -result [genpaths /FOO]
+
+test tm-3.13 {tm: module path management, roots} -setup {
+ # Save and clear the list
+ set defaults [::tcl::tm::path list]
+ foreach p $defaults {::tcl::tm::path remove $p}
+} -cleanup {
+ # Restore old contents of path list.
+ foreach p [::tcl::tm::path list] {::tcl::tm::path remove $p}
+ foreach p $defaults {::tcl::tm::path add $p}
+} -body {
+ ::tcl::tm::roots [list /FOO /BAR]
+ ::tcl::tm::path list
+} -result [concat [genpaths /BAR] [genpaths /FOO]]
+
+rename genpaths {}
::tcltest::cleanupTests
return