= 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 }