Mass Deface = 0} { return -code error \ "$p is ancestor of existing module path [lindex $newpaths $pos]." } # 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 $newpaths { if {[string match ${ep}/* $p]} { return -code error \ "$p is subdirectory of existing module path $ep." } } set newpaths [linsert $newpaths 0 $p] } # The validation of the input is complete and successful, and # everything in newpaths is either an old path, or added. We can # now extend the official list of paths, a simple assignment is # sufficient. set paths $newpaths return } proc ::tcl::tm::remove {path 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. variable paths foreach p [linsert $args 0 $path] { set pos [lsearch -exact $paths $p] if {$pos >= 0} { set paths [lreplace $paths $pos $pos] } } } proc ::tcl::tm::list {} { # PART OF THE ::tcl::tm::path ENSEMBLE variable paths return $paths } # ::tcl::tm::UnknownHandler -- # # Unknown handler for Tcl Modules, i.e. packages in module form. # # Arguments # original - Original [package unknown] procedure. # name - Name of desired package. # version - Version of desired package. Can be the # empty string. # exact - Either -exact or ommitted. # # Name, version, and exact are used to determine # satisfaction. The original is called iff no satisfaction was # achieved. The name is also used to compute the directory to # target in the search. # # Results # None. # # Sideeffects # May populate the package ifneeded database with additional # provide scripts. proc ::tcl::tm::UnknownHandler {original name args} { # Import the list of paths to search for packages in module form. # Import the pattern used to check package names in detail. variable paths variable pkgpattern # Without paths to search we can do nothing. (Except falling back # to the regular search). if {[llength $paths]} { set pkgpath [string map {:: /} $name] set pkgroot [file dirname $pkgpath] 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 # for them. This also simplifies the loop, as we cannot get # additional directories while iterating over the list. A # simple foreach is sufficient. set satisfied 0 foreach path $paths { if {![interp issafe] && ![file exists $path]} { continue } set currentsearchpath [file join $path $pkgroot] if {![interp issafe] && ![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 # of the subdirectories. In other words, Tcl Modules are # not-functional in such an interpreter. This is the same # as for the command "tclPkgUnknown", i.e. the search for # regular packages. catch { # We always look for _all_ possible modules in the current # path, to get the max result out of the glob. foreach file [glob -nocomplain -directory $currentsearchpath *.tm] { set pkgfilename [join [lrange [file split $file] $strip end] ::] if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { # Ignore everything not matching our pattern # for package names. continue } if {[catch {package vcompare $pkgversion 0}]} { # Ignore everything where the version part is # not acceptable to "package vcompare". continue } # We have found a candidate, generate a "provide # script" for it, and remember it. Note that we # are using ::list to do this; locally [list] # means something else without the namespace # specifier. # NOTE. When making changes to the format of the # provide command generated below CHECK that the # 'LOCATE' procedure in core file # 'platform/shell.tcl' still understands it, or, # if not, update its implementation appropriately. # # Right now LOCATE's implementation assumes that # the path of the package file is the last element # in the list. package ifneeded $pkgname $pkgversion \ "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]" # We abort in this unknown handler only if we got # a satisfying candidate for the requested # package. Otherwise we still have to fallback to # the regular package search to complete the # processing. if { ($pkgname eq $name) && [package vsatisfies $pkgversion {*}$args] } then { set satisfied 1 # We do not abort the loop, and keep adding # provide scripts for every candidate in the # directory, just remember to not fall back to # the regular search anymore. } } } } if {$satisfied} { return } } # Fallback to previous command, if existing. See comment above # about ::list... if {[llength $original]} { uplevel 1 $original [::linsert $args 0 $name] } } # ::tcl::tm::Defaults -- # # Determines the default search paths. # # Arguments # None # # Results # None. # # Sideeffects # May add paths to the list of defaults. proc ::tcl::tm::Defaults {} { global env tcl_platform lassign [split [info tclversion] .] major minor set exe [file normalize [info nameofexecutable]] # 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 dirname $exe]] lib] \ ] if {$tcl_platform(platform) eq "windows"} { set sep ";" } else { set sep ":" } for {set n $minor} {$n >= 0} {incr n -1} { foreach ev [::list \ TCL${major}.${n}_TM_PATH \ TCL${major}_${n}_TM_PATH \ ] { if {![info exists env($ev)]} continue foreach p [split $env($ev) $sep] { path add $p } } } return } # ::tcl::tm::roots -- # # Public API to the module path. See specification. # # Arguments # paths - List of 'root' paths to derive search paths from. # # Results # No result. # # Sideeffects # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { foreach {major minor} [split [info tclversion] .] break foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { set px [file join $p ${major}.${n}] if {![interp issafe]} { set px [file normalize $px] } path add $px } set px [file join $p site-tcl] if {![interp issafe]} { set px [file normalize $px] } path add $px } return } # Initialization. Set up the default paths, then insert the new # handler into the chain. if {![interp issafe]} { ::tcl::tm::Defaults }