summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog8
-rw-r--r--library/tm.tcl209
-rw-r--r--tests/tm.test31
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