Flesh out tests and transform the TM manager API into an ensemble

3 files changed, 146 insertions, 102 deletions

diff --git a/ChangeLog b/ChangeLog
index bad7ce1..0df87bb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-10-25  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
+
+	* tests/tm.test: Rewrote the tests to actually perform syntax
+	checks on the public API. Added a new test (currently failing) to
+	indicate that the test suite is not complete yet.
+	* library/tm.tcl (path): Rewrote to turn this command into an
+	ensemble to make it faster and simpler.
+
 2004-10-24  Miguel Sofer <msofer@users.sf.net>
 
 	* generic/tclCmdIL.c:
diff --git a/library/tm.tcl b/library/tm.tcl
index 38e656a..37f03cb 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -58,9 +58,10 @@ namespace eval ::tcl::tm {
     # Export the public API
 
     namespace export path
+    namespace ensemble create -command path -subcommand {add remove list}
 }
 
-# ::tcl::tm::path --
+# ::tcl::tm::path implementations --
 #
 #	Public API to the module path. See specification.
 #
@@ -78,92 +79,96 @@ namespace eval ::tcl::tm {
 #	paths to search for Tcl Modules. The subcommand 'list' has no
 #	sideeffects.
 
-proc ::tcl::tm::path {cmd args} {
-    variable paths
-    switch -exact -- $cmd {
-	add {
-	    # The path is added at the head to the list of module
-	    # paths.
-	    #
-	    # The command enforces the restriction that no path may be
-	    # an ancestor directory of any other path on the list. If
-	    # the new path violates this restriction an error wil be
-	    # raised.
-	    #
-	    # If the path is already present as is no error will be
-	    # raised and no action will be taken.
-
-	    if {![llength $args]} {
-		return -code error "wrong#args, expected: [lindex [info level 0] 0] add path path..."
-	    }
+proc ::tcl::tm::add {args} {
+    # PART OF THE ::tcl::tm::path ENSEMBLE
+    #
+    # The path is added at the head to the list of module paths.
+    #
+    # The command enforces the restriction that no path may be an
+    # ancestor directory of any other path on the list. If the new
+    # path violates this restriction an error wil be raised.
+    #
+    # If the path is already present as is no error will be raised and
+    # no action will be taken.
+
+    if {[llength $args] == 0} {
+	return -code error \
+	    "wrong # args: should be \"::tcl::tm::path add path ?path ...?\""
+    }
 
-	    set newpaths {}
-	    foreach p $args {
-		set pos [lsearch -exact $paths $p]
-		if {$pos >= 0} {
-		    # Ignore a path already on the list.
-		    continue
-		}
+    variable paths
 
-		# Search for paths which are subdirectories of the new
-		# one. If there are any then new path violates the
-		# restriction about ancestors.
+    set newpaths {}
+    foreach p $args {
+	set pos [lsearch -exact $paths $p]
+	if {$pos >= 0} {
+	    # Ignore a path already on the list.
+	    continue
+	}
 
-		set pos [lsearch -glob $paths ${p}/*]
-		if {$pos >= 0} {
-		    return -code error "$p is ancestor of existing module path [lindex $paths $pos]."
-		}
+	# Search for paths which are subdirectories of the new one. If
+	# there are any then new path violates the restriction about
+	# ancestors.
 
-		# Now look for paths which are ancestors of the new
-		# one. This reverse question req us to loop over the
-		# existing paths :(
+	set pos [lsearch -glob $paths ${p}/*]
+	if {$pos >= 0} {
+	    return -code error \
+		"$p is ancestor of existing module path [lindex $paths $pos]."
+	}
 
-		foreach ep $paths {
-		    if {[string match ${ep}/* $p]} {
-			return -code error "$p is subdirectory of existing module path $ep."
-		    }
-		}
+	# Now look for paths which are ancestors of the new one. This
+	# reverse question req us to loop over the existing paths :(
 
-		lappend newpaths $p
+	foreach ep $paths {
+	    if {[string match ${ep}/* $p]} {
+		return -code error \
+		    "$p is subdirectory of existing module path $ep."
 	    }
+	}
 
-	    # The validation of the input is complete and successful,
-	    # and everything in newpaths is actually new. We can now
-	    # extend the list of paths.
+	lappend newpaths $p
+    }
 
-	    foreach p $newpaths {
-		set paths [linsert $paths 0 $p]
-	    }
-	}
-	remove {
-	    # Removes the path from the list of module paths. The
-	    # command is silently ignored if the path is not on the
-	    # list.
+    # The validation of the input is complete and successful, and
+    # everything in newpaths is actually new. We can now extend the
+    # list of paths.
 
-	    if {![llength $args]} {
-		return -code error "wrong#args, expected: [lindex [info level 0] 0] remove path path ..."
-	    }
+    foreach p $newpaths {
+	set paths [linsert $paths 0 $p]
+    }
+}
+proc ::tcl::tm::remove {args} {
+    # PART OF THE ::tcl::tm::path ENSEMBLE
+    #
+    # Removes the path from the list of module paths. The command is
+    # silently ignored if the path is not on the list.
+
+    if {[llength $args] == 0} {
+	return -code error \
+	    "wrong # args: should be \"::tcl::tm::path remove path ?path ...?\""
+    }
 
-	    foreach p $args {
-		set pos [lsearch -exact $paths $p]
-		if {$pos >= 0} {
-		    set paths [lreplace $paths $pos $pos]
-		}
-	    }
-	}
-	list {
-	    if {[llength $args]} {
-		return -code error "wrong#args, expected: [lindex [info level 0] 0] list"
-	    }
-	    return $paths
-	}
-	default {
-	    return -code error "Expect one of add, remove, or list, got \"$cmd\""
+    variable paths
+
+    foreach p $args {
+	set pos [lsearch -exact $paths $p]
+	if {$pos >= 0} {
+	    set paths [lreplace $paths $pos $pos]
 	}
     }
 }
+proc ::tcl::tm::list {args} {
+    # PART OF THE ::tcl::tm::path ENSEMBLE
+
+    if {[llength $args] != 0} {
+	return -code error "wrong # args: should be \"::tcl::tm::path list\""
+    }
+    variable paths
+
+    return $paths
+}
 
-# ::tcl::tm::unknown --
+# ::tcl::tm::UnknownHandler --
 #
 #	Unknown handler for Tcl Modules, i.e. packages in module form.
 #
@@ -186,7 +191,7 @@ proc ::tcl::tm::path {cmd args} {
 #	May populate the package ifneeded database with additional
 #	provide scripts.
 
-proc ::tcl::tm::unknown {original name version {exact {}}} {
+proc ::tcl::tm::UnknownHandler {original name version {exact {}}} {
     # Import the list of paths to search for packages in module form.
     # Import the pattern used to check package names in detail.  
 
@@ -199,7 +204,9 @@ proc ::tcl::tm::unknown {original name version {exact {}}} {
     if {[llength $paths]} {
 	set pkgpath [string map {:: /} $name]
 	set pkgroot [file dirname $pkgpath]
-	if {$pkgroot eq "."} {set pkgroot ""}
+	if {$pkgroot eq "."} {
+	    set pkgroot ""
+	}
 
 	# We don't remember a copy of the paths while looping. Tcl
 	# Modules are unable to change the list while we are searching
@@ -209,10 +216,14 @@ proc ::tcl::tm::unknown {original name version {exact {}}} {
 
 	set satisfied 0
 	foreach path $paths {
-	    if {![file exists $path]} continue
+	    if {![file exists $path]} {
+		continue
+	    }
 	    set currentsearchpath [file join $path $pkgroot]
-	    if {![file exists $currentsearchpath]} continue
-	    set strip             [llength [file split $path]]
+	    if {![file exists $currentsearchpath]} {
+		continue
+	    }
+	    set strip [llength [file split $path]]
 
 	    # We can't use glob in safe interps, so enclose the following
 	    # in a catch statement, where we get the module files out
@@ -240,9 +251,12 @@ proc ::tcl::tm::unknown {original name version {exact {}}} {
 		    }
 
 		    # We have found a candidate, generate a "provide
-		    # script" for it, and remember it.
+		    # script" for it, and remember it.  Note that we
+		    # are using ::list to do this; locally [list]
+		    # means something else without the namespace
+		    # specifier.
 
-		    package ifneeded $pkgname $pkgversion [list source $file]
+		    package ifneeded $pkgname $pkgversion [::list source $file]
 
 		    # We abort in this unknown handler only if we got
 		    # a satisfying candidate for the requested
@@ -251,11 +265,11 @@ proc ::tcl::tm::unknown {original name version {exact {}}} {
 		    # processing.
 
 		    if {
-			($pkgname eq $name) &&
-			((($exact eq "-exact") && (0==[package vcompare $pkgversion $version])) ||
-			(($version ne "") && [package vsatisfies $pkgversion $version]) ||
+			$pkgname eq $name && (
+			($exact eq "-exact" && ![package vcompare $pkgversion $version]) ||
+			($version ne "" && [package vsatisfies $pkgversion $version]) ||
 			($version eq ""))
-		    } {
+		    } then {
 			set satisfied 1
 			# We do not abort the loop, and keep adding
 			# provide scripts for every candidate in the
@@ -271,9 +285,11 @@ proc ::tcl::tm::unknown {original name version {exact {}}} {
 	}
     }
 
-    # Fallback to previous command, if existing.
+    # Fallback to previous command, if existing.  See comment above
+    # about ::list...
+
     if {[llength $original]} {
-	uplevel 1 $original [list $name $version $exact]
+	uplevel 1 $original [::list $name $version $exact]
     }
 }
 
@@ -291,22 +307,27 @@ proc ::tcl::tm::unknown {original name version {exact {}}} {
 #	May add paths to the list of defaults.
 
 proc ::tcl::tm::Defaults {} {
-    foreach {major minor} [split [info tclversion] .] break
+    global env tcl_platform
+
+    lassign [split [info tclversion] .] major minor
+    set exe [file normalize [info nameofexecutable]]
 
-    roots [list \
+    # Note that we're using [::list], not [list] because [list] means
+    # something other than [::list] in this namespace.
+    roots [::list \
 	    [file dirname [info library]] \
-	    [file join [file dirname [file normalize [info nameofexecutable]]] lib] \
+	    [file join [file dirname $exe] lib] \
 	    ]
 
-    if {$::tcl_platform(platform) eq "windows"} {
-	set sep \;
+    if {$tcl_platform(platform) eq "windows"} {
+	set sep ";"
     } else {
-	set sep :
+	set sep ":"
     }
     for {set n $minor} {$n >= 0} {incr n -1} {
 	set ev TCL${major}.{$n}_TM_PATH
-	if {[info exists ::env($ev)]} {
-	    foreach p [split $::env($ev) $sep] {
+	if {[info exists env($ev)]} {
+	    foreach p [split $env($ev) $sep] {
 		path add $p
 	    }
 	}
@@ -343,4 +364,4 @@ proc ::tcl::tm::roots {paths} {
 # handler into the chain.
 
 ::tcl::tm::Defaults
-package unknown [list ::tcl::tm::unknown [package unknown]]
+package unknown [list ::tcl::tm::UnknownHandler [package unknown]]
diff --git a/tests/tm.test b/tests/tm.test
index d270f59..ada4d46 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.1 2004/10/22 22:08:25 dkf Exp $
+# RCS: @(#) $Id: tm.test,v 1.2 2004/10/25 15:37:16 dkf Exp $
 
 package require Tcl 8.5
 if {"::tcltest" ni [namespace children]} {
@@ -18,19 +18,34 @@ test tm-1.1 {tm: path command exists} {
     catch { ::tcl::tm::path }
     info commands ::tcl::tm::path
 } ::tcl::tm::path
-test tm-1.2 {tm: path command syntax} {
-    ::tcl::tm::path FIXME
-} FIXME
-# Andreas Kupries needs to write some tests here...
+test tm-1.2 {tm: path command syntax} -returnCodes error -body {
+    ::tcl::tm::path foo
+} -result {unknown or ambiguous subcommand "foo": must be add, list, or remove}
+test tm-1.3 {tm: path command syntax} -returnCodes error -body {
+    ::tcl::tm::path add
+} -result "wrong # args: should be \"::tcl::tm::path add path ?path ...?\""
+test tm-1.4 {tm: path command syntax} -returnCodes error -body {
+    ::tcl::tm::path remove
+} -result "wrong # args: should be \"::tcl::tm::path remove path ?path ...?\""
+test tm-1.5 {tm: path command syntax} -returnCodes error -body {
+    ::tcl::tm::path list foobar
+} -result "wrong # args: should be \"::tcl::tm::path list\""
 
 test tm-2.1 {tm: roots command exists} {
     catch { ::tcl::tm::roots }
     info commands ::tcl::tm::roots
 } ::tcl::tm::roots
-test tm-1.2 {tm: roots command syntax} {
+test tm-2.2 {tm: roots command syntax} -returnCodes error -body {
     ::tcl::tm::roots
-} FIXME
-# Andreas Kupries needs to write some tests here...
+} -result "wrong # args: should be \"::tcl::tm::roots paths\""
+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
+} {}
 
 ::tcltest::cleanupTests
 return