3 # Searching for Tcl Modules. Defines a procedure, declares it as the
4 # primary command for finding packages, however also uses the former
5 # 'package unknown' command as a fallback.
7 # Locates all possible packages in a directory via a less restricted
8 # glob. The targeted directory is derived from the name of the
9 # requested package. I.e. the TM scan will look only at directories
10 # which can contain the requested package. It will register all
11 # packages it found in the directory so that future requests have a
12 # higher chance of being fulfilled by the ifneeded database without
13 # having to come to us again.
15 # We do not remember where we have been and simply rescan targeted
16 # directories when invoked again. The reasoning is this:
18 # - The only way we get back to the same directory is if someone is
19 # trying to [package require] something that wasn't there on the
23 # 1) It is there now: If we rescan, you get it; if not you don't.
25 # This covers the possibility that the application asked for a
26 # package late, and the package was actually added to the
27 # installation after the application was started. It shoukld
28 # still be able to find it.
30 # 2) It still is not there: Either way, you don't get it, but the
31 # rescan takes time. This is however an error case and we dont't
32 # care that much about it
34 # 3) It was there the first time; but for some reason a "package
35 # forget" has been run, and "package" doesn't know about it
38 # This can be an indication that the application wishes to reload
39 # some functionality. And should work as well.
41 # Note that this also strikes a balance between doing a glob targeting
42 # a single package, and thus most likely requiring multiple globs of
43 # the same directory when the application is asking for many packages,
44 # and trying to glob for _everything_ in all subdirectories when
45 # looking for a package, which comes with a heavy startup cost.
47 # We scan for regular packages only if no satisfying module was found.
49 namespace eval ::tcl::tm {
50 # Default paths. None yet.
54 # The regex pattern a file name has to match to make it a Tcl Module.
56 set pkgpattern
{^
([_
[:alpha
:]][:_
[:alnum
:]]*)-([[:digit
:]].
*)[.
]tm
$}
58 # Export the public API
61 namespace ensemble create
-command path
-subcommand {add remove
list}
64 # ::tcl::tm::path implementations --
66 # Public API to the module path. See specification.
69 # cmd - The subcommand to execute
70 # args - The paths to add/remove. Must not appear querying the
74 # No result for subcommands 'add' and 'remove'. A list of paths
78 # The subcommands 'add' and 'remove' manipulate the list of
79 # paths to search for Tcl Modules. The subcommand 'list' has no
82 proc ::tcl::tm::add {path args
} {
83 # PART OF THE ::tcl::tm::path ENSEMBLE
85 # The path is added at the head to the list of module paths.
87 # The command enforces the restriction that no path may be an
88 # ancestor directory of any other path on the list. If the new
89 # path violates this restriction an error wil be raised.
91 # If the path is already present as is no error will be raised and
92 # no action will be taken.
96 # We use a copy of the path as source during validation, and
97 # extend it as well. Because we not only have to detect if the new
98 # paths are bogus with respect to the existing paths, but also
99 # between themselves. Otherwise we can still add bogus paths, by
100 # specifying them in a single call. This makes the use of the new
101 # paths simpler as well, a trivial assignment of the collected
102 # paths to the official state var.
105 foreach p
[linsert $args 0 $path] {
106 if {$p in
$newpaths} {
107 # Ignore a path already on the list.
111 # Search for paths which are subdirectories of the new one. If
112 # there are any then the new path violates the restriction
115 set pos
[lsearch -glob $newpaths ${p
}/*]
116 # Cannot use "in", we need the position for the message.
119 "$p is ancestor of existing module path [lindex $newpaths $pos]."
122 # Now look for existing paths which are ancestors of the new
123 # one. This reverse question forces us to loop over the
124 # existing paths, as each element is the pattern, not the new
127 foreach ep
$newpaths {
128 if {[string match
${ep
}/* $p]} {
130 "$p is subdirectory of existing module path $ep."
134 set newpaths
[linsert $newpaths 0 $p]
137 # The validation of the input is complete and successful, and
138 # everything in newpaths is either an old path, or added. We can
139 # now extend the official list of paths, a simple assignment is
146 proc ::tcl::tm::remove {path args
} {
147 # PART OF THE ::tcl::tm::path ENSEMBLE
149 # Removes the path from the list of module paths. The command is
150 # silently ignored if the path is not on the list.
154 foreach p
[linsert $args 0 $path] {
155 set pos
[lsearch -exact $paths $p]
157 set paths
[lreplace $paths $pos $pos]
162 proc ::tcl::tm::list {} {
163 # PART OF THE ::tcl::tm::path ENSEMBLE
169 # ::tcl::tm::UnknownHandler --
171 # Unknown handler for Tcl Modules, i.e. packages in module form.
174 # original - Original [package unknown] procedure.
175 # name - Name of desired package.
176 # version - Version of desired package. Can be the
178 # exact - Either -exact or ommitted.
180 # Name, version, and exact are used to determine
181 # satisfaction. The original is called iff no satisfaction was
182 # achieved. The name is also used to compute the directory to
183 # target in the search.
189 # May populate the package ifneeded database with additional
192 proc ::tcl::tm::UnknownHandler {original name args
} {
193 # Import the list of paths to search for packages in module form.
194 # Import the pattern used to check package names in detail.
199 # Without paths to search we can do nothing. (Except falling back
200 # to the regular search).
202 if {[llength $paths]} {
203 set pkgpath
[string map
{:: /} $name]
204 set pkgroot
[file dirname
$pkgpath]
205 if {$pkgroot eq
"."} {
209 # We don't remember a copy of the paths while looping. Tcl
210 # Modules are unable to change the list while we are searching
211 # for them. This also simplifies the loop, as we cannot get
212 # additional directories while iterating over the list. A
213 # simple foreach is sufficient.
216 foreach path
$paths {
217 if {![interp issafe
] && ![file exists
$path]} {
220 set currentsearchpath
[file join $path $pkgroot]
221 if {![interp issafe
] && ![file exists
$currentsearchpath]} {
224 set strip
[llength [file split $path]]
226 # We can't use glob in safe interps, so enclose the following
227 # in a catch statement, where we get the module files out
228 # of the subdirectories. In other words, Tcl Modules are
229 # not-functional in such an interpreter. This is the same
230 # as for the command "tclPkgUnknown", i.e. the search for
234 # We always look for _all_ possible modules in the current
235 # path, to get the max result out of the glob.
237 foreach file [glob -nocomplain -directory $currentsearchpath *.tm
] {
238 set pkgfilename
[join [lrange [file split $file] $strip end
] ::]
240 if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion
]} {
241 # Ignore everything not matching our pattern
245 if {[catch {package vcompare
$pkgversion 0}]} {
246 # Ignore everything where the version part is
247 # not acceptable to "package vcompare".
251 # We have found a candidate, generate a "provide
252 # script" for it, and remember it. Note that we
253 # are using ::list to do this; locally [list]
254 # means something else without the namespace
257 # NOTE. When making changes to the format of the
258 # provide command generated below CHECK that the
259 # 'LOCATE' procedure in core file
260 # 'platform/shell.tcl' still understands it, or,
261 # if not, update its implementation appropriately.
263 # Right now LOCATE's implementation assumes that
264 # the path of the package file is the last element
267 package ifneeded
$pkgname $pkgversion \
268 "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
270 # We abort in this unknown handler only if we got
271 # a satisfying candidate for the requested
272 # package. Otherwise we still have to fallback to
273 # the regular package search to complete the
277 ($pkgname eq
$name) &&
278 [package vsatisfies
$pkgversion {*}$args]
281 # We do not abort the loop, and keep adding
282 # provide scripts for every candidate in the
283 # directory, just remember to not fall back to
284 # the regular search anymore.
295 # Fallback to previous command, if existing. See comment above
298 if {[llength $original]} {
299 uplevel 1 $original [::linsert $args 0 $name]
303 # ::tcl::tm::Defaults --
305 # Determines the default search paths.
314 # May add paths to the list of defaults.
316 proc ::tcl::tm::Defaults {} {
317 global env tcl_platform
319 lassign
[split [info tclversion
] .
] major minor
320 set exe
[file normalize
[info nameofexecutable
]]
322 # Note that we're using [::list], not [list] because [list] means
323 # something other than [::list] in this namespace.
325 [file dirname
[info library
]] \
326 [file join [file dirname
[file dirname
$exe]] lib
] \
329 if {$tcl_platform(platform
) eq
"windows"} {
334 for {set n
$minor} {$n >= 0} {incr n
-1} {
336 TCL
${major
}.
${n
}_TM_PATH
\
337 TCL
${major
}_
${n
}_TM_PATH
\
339 if {![info exists env
($ev)]} continue
340 foreach p
[split $env($ev) $sep] {
348 # ::tcl::tm::roots --
350 # Public API to the module path. See specification.
353 # paths - List of 'root' paths to derive search paths from.
359 # Calls 'path add' to paths to the list of module search paths.
361 proc ::tcl::tm::roots {paths
} {
362 foreach {major minor
} [split [info tclversion
] .
] break
364 set p
[file join $pa tcl
$major]
365 for {set n
$minor} {$n >= 0} {incr n
-1} {
366 set px
[file join $p ${major
}.
${n
}]
367 if {![interp issafe
]} { set px
[file normalize
$px] }
370 set px
[file join $p site-tcl
]
371 if {![interp issafe
]} { set px
[file normalize
$px] }
377 # Initialization. Set up the default paths, then insert the new
378 # handler into the chain.
380 if {![interp issafe
]} { ::tcl::tm::Defaults }