diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | library/tm.tcl | 209 | ||||
| -rw-r--r-- | tests/tm.test | 31 |
3 files changed, 146 insertions, 102 deletions
@@ -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 |