|
jpayne@68
|
1 # -*- tcl -*-
|
|
jpayne@68
|
2 #
|
|
jpayne@68
|
3 # Searching for Tcl Modules. Defines a procedure, declares it as the primary
|
|
jpayne@68
|
4 # command for finding packages, however also uses the former 'package unknown'
|
|
jpayne@68
|
5 # command as a fallback.
|
|
jpayne@68
|
6 #
|
|
jpayne@68
|
7 # Locates all possible packages in a directory via a less restricted glob. The
|
|
jpayne@68
|
8 # targeted directory is derived from the name of the requested package, i.e.
|
|
jpayne@68
|
9 # the TM scan will look only at directories which can contain the requested
|
|
jpayne@68
|
10 # package. It will register all packages it found in the directory so that
|
|
jpayne@68
|
11 # future requests have a higher chance of being fulfilled by the ifneeded
|
|
jpayne@68
|
12 # database without having to come to us again.
|
|
jpayne@68
|
13 #
|
|
jpayne@68
|
14 # We do not remember where we have been and simply rescan targeted directories
|
|
jpayne@68
|
15 # when invoked again. The reasoning is this:
|
|
jpayne@68
|
16 #
|
|
jpayne@68
|
17 # - The only way we get back to the same directory is if someone is trying to
|
|
jpayne@68
|
18 # [package require] something that wasn't there on the first scan.
|
|
jpayne@68
|
19 #
|
|
jpayne@68
|
20 # Either
|
|
jpayne@68
|
21 # 1) It is there now: If we rescan, you get it; if not you don't.
|
|
jpayne@68
|
22 #
|
|
jpayne@68
|
23 # This covers the possibility that the application asked for a package
|
|
jpayne@68
|
24 # late, and the package was actually added to the installation after the
|
|
jpayne@68
|
25 # application was started. It shoukld still be able to find it.
|
|
jpayne@68
|
26 #
|
|
jpayne@68
|
27 # 2) It still is not there: Either way, you don't get it, but the rescan
|
|
jpayne@68
|
28 # takes time. This is however an error case and we dont't care that much
|
|
jpayne@68
|
29 # about it
|
|
jpayne@68
|
30 #
|
|
jpayne@68
|
31 # 3) It was there the first time; but for some reason a "package forget" has
|
|
jpayne@68
|
32 # been run, and "package" doesn't know about it anymore.
|
|
jpayne@68
|
33 #
|
|
jpayne@68
|
34 # This can be an indication that the application wishes to reload some
|
|
jpayne@68
|
35 # functionality. And should work as well.
|
|
jpayne@68
|
36 #
|
|
jpayne@68
|
37 # Note that this also strikes a balance between doing a glob targeting a
|
|
jpayne@68
|
38 # single package, and thus most likely requiring multiple globs of the same
|
|
jpayne@68
|
39 # directory when the application is asking for many packages, and trying to
|
|
jpayne@68
|
40 # glob for _everything_ in all subdirectories when looking for a package,
|
|
jpayne@68
|
41 # which comes with a heavy startup cost.
|
|
jpayne@68
|
42 #
|
|
jpayne@68
|
43 # We scan for regular packages only if no satisfying module was found.
|
|
jpayne@68
|
44
|
|
jpayne@68
|
45 namespace eval ::tcl::tm {
|
|
jpayne@68
|
46 # Default paths. None yet.
|
|
jpayne@68
|
47
|
|
jpayne@68
|
48 variable paths {}
|
|
jpayne@68
|
49
|
|
jpayne@68
|
50 # The regex pattern a file name has to match to make it a Tcl Module.
|
|
jpayne@68
|
51
|
|
jpayne@68
|
52 set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}
|
|
jpayne@68
|
53
|
|
jpayne@68
|
54 # Export the public API
|
|
jpayne@68
|
55
|
|
jpayne@68
|
56 namespace export path
|
|
jpayne@68
|
57 namespace ensemble create -command path -subcommands {add remove list}
|
|
jpayne@68
|
58 }
|
|
jpayne@68
|
59
|
|
jpayne@68
|
60 # ::tcl::tm::path implementations --
|
|
jpayne@68
|
61 #
|
|
jpayne@68
|
62 # Public API to the module path. See specification.
|
|
jpayne@68
|
63 #
|
|
jpayne@68
|
64 # Arguments
|
|
jpayne@68
|
65 # cmd - The subcommand to execute
|
|
jpayne@68
|
66 # args - The paths to add/remove. Must not appear querying the
|
|
jpayne@68
|
67 # path with 'list'.
|
|
jpayne@68
|
68 #
|
|
jpayne@68
|
69 # Results
|
|
jpayne@68
|
70 # No result for subcommands 'add' and 'remove'. A list of paths for
|
|
jpayne@68
|
71 # 'list'.
|
|
jpayne@68
|
72 #
|
|
jpayne@68
|
73 # Sideeffects
|
|
jpayne@68
|
74 # The subcommands 'add' and 'remove' manipulate the list of paths to
|
|
jpayne@68
|
75 # search for Tcl Modules. The subcommand 'list' has no sideeffects.
|
|
jpayne@68
|
76
|
|
jpayne@68
|
77 proc ::tcl::tm::add {args} {
|
|
jpayne@68
|
78 # PART OF THE ::tcl::tm::path ENSEMBLE
|
|
jpayne@68
|
79 #
|
|
jpayne@68
|
80 # The path is added at the head to the list of module paths.
|
|
jpayne@68
|
81 #
|
|
jpayne@68
|
82 # The command enforces the restriction that no path may be an ancestor
|
|
jpayne@68
|
83 # directory of any other path on the list. If the new path violates this
|
|
jpayne@68
|
84 # restriction an error wil be raised.
|
|
jpayne@68
|
85 #
|
|
jpayne@68
|
86 # If the path is already present as is no error will be raised and no
|
|
jpayne@68
|
87 # action will be taken.
|
|
jpayne@68
|
88
|
|
jpayne@68
|
89 variable paths
|
|
jpayne@68
|
90
|
|
jpayne@68
|
91 # We use a copy of the path as source during validation, and extend it as
|
|
jpayne@68
|
92 # well. Because we not only have to detect if the new paths are bogus with
|
|
jpayne@68
|
93 # respect to the existing paths, but also between themselves. Otherwise we
|
|
jpayne@68
|
94 # can still add bogus paths, by specifying them in a single call. This
|
|
jpayne@68
|
95 # makes the use of the new paths simpler as well, a trivial assignment of
|
|
jpayne@68
|
96 # the collected paths to the official state var.
|
|
jpayne@68
|
97
|
|
jpayne@68
|
98 set newpaths $paths
|
|
jpayne@68
|
99 foreach p $args {
|
|
jpayne@68
|
100 if {$p in $newpaths} {
|
|
jpayne@68
|
101 # Ignore a path already on the list.
|
|
jpayne@68
|
102 continue
|
|
jpayne@68
|
103 }
|
|
jpayne@68
|
104
|
|
jpayne@68
|
105 # Search for paths which are subdirectories of the new one. If there
|
|
jpayne@68
|
106 # are any then the new path violates the restriction about ancestors.
|
|
jpayne@68
|
107
|
|
jpayne@68
|
108 set pos [lsearch -glob $newpaths ${p}/*]
|
|
jpayne@68
|
109 # Cannot use "in", we need the position for the message.
|
|
jpayne@68
|
110 if {$pos >= 0} {
|
|
jpayne@68
|
111 return -code error \
|
|
jpayne@68
|
112 "$p is ancestor of existing module path [lindex $newpaths $pos]."
|
|
jpayne@68
|
113 }
|
|
jpayne@68
|
114
|
|
jpayne@68
|
115 # Now look for existing paths which are ancestors of the new one. This
|
|
jpayne@68
|
116 # reverse question forces us to loop over the existing paths, as each
|
|
jpayne@68
|
117 # element is the pattern, not the new path :(
|
|
jpayne@68
|
118
|
|
jpayne@68
|
119 foreach ep $newpaths {
|
|
jpayne@68
|
120 if {[string match ${ep}/* $p]} {
|
|
jpayne@68
|
121 return -code error \
|
|
jpayne@68
|
122 "$p is subdirectory of existing module path $ep."
|
|
jpayne@68
|
123 }
|
|
jpayne@68
|
124 }
|
|
jpayne@68
|
125
|
|
jpayne@68
|
126 set newpaths [linsert $newpaths 0 $p]
|
|
jpayne@68
|
127 }
|
|
jpayne@68
|
128
|
|
jpayne@68
|
129 # The validation of the input is complete and successful, and everything
|
|
jpayne@68
|
130 # in newpaths is either an old path, or added. We can now extend the
|
|
jpayne@68
|
131 # official list of paths, a simple assignment is sufficient.
|
|
jpayne@68
|
132
|
|
jpayne@68
|
133 set paths $newpaths
|
|
jpayne@68
|
134 return
|
|
jpayne@68
|
135 }
|
|
jpayne@68
|
136
|
|
jpayne@68
|
137 proc ::tcl::tm::remove {args} {
|
|
jpayne@68
|
138 # PART OF THE ::tcl::tm::path ENSEMBLE
|
|
jpayne@68
|
139 #
|
|
jpayne@68
|
140 # Removes the path from the list of module paths. The command is silently
|
|
jpayne@68
|
141 # ignored if the path is not on the list.
|
|
jpayne@68
|
142
|
|
jpayne@68
|
143 variable paths
|
|
jpayne@68
|
144
|
|
jpayne@68
|
145 foreach p $args {
|
|
jpayne@68
|
146 set pos [lsearch -exact $paths $p]
|
|
jpayne@68
|
147 if {$pos >= 0} {
|
|
jpayne@68
|
148 set paths [lreplace $paths $pos $pos]
|
|
jpayne@68
|
149 }
|
|
jpayne@68
|
150 }
|
|
jpayne@68
|
151 }
|
|
jpayne@68
|
152
|
|
jpayne@68
|
153 proc ::tcl::tm::list {} {
|
|
jpayne@68
|
154 # PART OF THE ::tcl::tm::path ENSEMBLE
|
|
jpayne@68
|
155
|
|
jpayne@68
|
156 variable paths
|
|
jpayne@68
|
157 return $paths
|
|
jpayne@68
|
158 }
|
|
jpayne@68
|
159
|
|
jpayne@68
|
160 # ::tcl::tm::UnknownHandler --
|
|
jpayne@68
|
161 #
|
|
jpayne@68
|
162 # Unknown handler for Tcl Modules, i.e. packages in module form.
|
|
jpayne@68
|
163 #
|
|
jpayne@68
|
164 # Arguments
|
|
jpayne@68
|
165 # original - Original [package unknown] procedure.
|
|
jpayne@68
|
166 # name - Name of desired package.
|
|
jpayne@68
|
167 # version - Version of desired package. Can be the
|
|
jpayne@68
|
168 # empty string.
|
|
jpayne@68
|
169 # exact - Either -exact or ommitted.
|
|
jpayne@68
|
170 #
|
|
jpayne@68
|
171 # Name, version, and exact are used to determine satisfaction. The
|
|
jpayne@68
|
172 # original is called iff no satisfaction was achieved. The name is also
|
|
jpayne@68
|
173 # used to compute the directory to target in the search.
|
|
jpayne@68
|
174 #
|
|
jpayne@68
|
175 # Results
|
|
jpayne@68
|
176 # None.
|
|
jpayne@68
|
177 #
|
|
jpayne@68
|
178 # Sideeffects
|
|
jpayne@68
|
179 # May populate the package ifneeded database with additional provide
|
|
jpayne@68
|
180 # scripts.
|
|
jpayne@68
|
181
|
|
jpayne@68
|
182 proc ::tcl::tm::UnknownHandler {original name args} {
|
|
jpayne@68
|
183 # Import the list of paths to search for packages in module form.
|
|
jpayne@68
|
184 # Import the pattern used to check package names in detail.
|
|
jpayne@68
|
185
|
|
jpayne@68
|
186 variable paths
|
|
jpayne@68
|
187 variable pkgpattern
|
|
jpayne@68
|
188
|
|
jpayne@68
|
189 # Without paths to search we can do nothing. (Except falling back to the
|
|
jpayne@68
|
190 # regular search).
|
|
jpayne@68
|
191
|
|
jpayne@68
|
192 if {[llength $paths]} {
|
|
jpayne@68
|
193 set pkgpath [string map {:: /} $name]
|
|
jpayne@68
|
194 set pkgroot [file dirname $pkgpath]
|
|
jpayne@68
|
195 if {$pkgroot eq "."} {
|
|
jpayne@68
|
196 set pkgroot ""
|
|
jpayne@68
|
197 }
|
|
jpayne@68
|
198
|
|
jpayne@68
|
199 # We don't remember a copy of the paths while looping. Tcl Modules are
|
|
jpayne@68
|
200 # unable to change the list while we are searching for them. This also
|
|
jpayne@68
|
201 # simplifies the loop, as we cannot get additional directories while
|
|
jpayne@68
|
202 # iterating over the list. A simple foreach is sufficient.
|
|
jpayne@68
|
203
|
|
jpayne@68
|
204 set satisfied 0
|
|
jpayne@68
|
205 foreach path $paths {
|
|
jpayne@68
|
206 if {![interp issafe] && ![file exists $path]} {
|
|
jpayne@68
|
207 continue
|
|
jpayne@68
|
208 }
|
|
jpayne@68
|
209 set currentsearchpath [file join $path $pkgroot]
|
|
jpayne@68
|
210 if {![interp issafe] && ![file exists $currentsearchpath]} {
|
|
jpayne@68
|
211 continue
|
|
jpayne@68
|
212 }
|
|
jpayne@68
|
213 set strip [llength [file split $path]]
|
|
jpayne@68
|
214
|
|
jpayne@68
|
215 # Get the module files out of the subdirectories.
|
|
jpayne@68
|
216 # - Safe Base interpreters have a restricted "glob" command that
|
|
jpayne@68
|
217 # works in this case.
|
|
jpayne@68
|
218 # - The "catch" was essential when there was no safe glob and every
|
|
jpayne@68
|
219 # call in a safe interp failed; it is retained only for corner
|
|
jpayne@68
|
220 # cases in which the eventual call to glob returns an error.
|
|
jpayne@68
|
221
|
|
jpayne@68
|
222 catch {
|
|
jpayne@68
|
223 # We always look for _all_ possible modules in the current
|
|
jpayne@68
|
224 # path, to get the max result out of the glob.
|
|
jpayne@68
|
225
|
|
jpayne@68
|
226 foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
|
|
jpayne@68
|
227 set pkgfilename [join [lrange [file split $file] $strip end] ::]
|
|
jpayne@68
|
228
|
|
jpayne@68
|
229 if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
|
|
jpayne@68
|
230 # Ignore everything not matching our pattern for
|
|
jpayne@68
|
231 # package names.
|
|
jpayne@68
|
232 continue
|
|
jpayne@68
|
233 }
|
|
jpayne@68
|
234 try {
|
|
jpayne@68
|
235 package vcompare $pkgversion 0
|
|
jpayne@68
|
236 } on error {} {
|
|
jpayne@68
|
237 # Ignore everything where the version part is not
|
|
jpayne@68
|
238 # acceptable to "package vcompare".
|
|
jpayne@68
|
239 continue
|
|
jpayne@68
|
240 }
|
|
jpayne@68
|
241
|
|
jpayne@68
|
242 if {([package ifneeded $pkgname $pkgversion] ne {})
|
|
jpayne@68
|
243 && (![interp issafe])
|
|
jpayne@68
|
244 } {
|
|
jpayne@68
|
245 # There's already a provide script registered for
|
|
jpayne@68
|
246 # this version of this package. Since all units of
|
|
jpayne@68
|
247 # code claiming to be the same version of the same
|
|
jpayne@68
|
248 # package ought to be identical, just stick with
|
|
jpayne@68
|
249 # the one we already have.
|
|
jpayne@68
|
250 # This does not apply to Safe Base interpreters because
|
|
jpayne@68
|
251 # the token-to-directory mapping may have changed.
|
|
jpayne@68
|
252 continue
|
|
jpayne@68
|
253 }
|
|
jpayne@68
|
254
|
|
jpayne@68
|
255 # We have found a candidate, generate a "provide script"
|
|
jpayne@68
|
256 # for it, and remember it. Note that we are using ::list
|
|
jpayne@68
|
257 # to do this; locally [list] means something else without
|
|
jpayne@68
|
258 # the namespace specifier.
|
|
jpayne@68
|
259
|
|
jpayne@68
|
260 # NOTE. When making changes to the format of the provide
|
|
jpayne@68
|
261 # command generated below CHECK that the 'LOCATE'
|
|
jpayne@68
|
262 # procedure in core file 'platform/shell.tcl' still
|
|
jpayne@68
|
263 # understands it, or, if not, update its implementation
|
|
jpayne@68
|
264 # appropriately.
|
|
jpayne@68
|
265 #
|
|
jpayne@68
|
266 # Right now LOCATE's implementation assumes that the path
|
|
jpayne@68
|
267 # of the package file is the last element in the list.
|
|
jpayne@68
|
268
|
|
jpayne@68
|
269 package ifneeded $pkgname $pkgversion \
|
|
jpayne@68
|
270 "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
|
|
jpayne@68
|
271
|
|
jpayne@68
|
272 # We abort in this unknown handler only if we got a
|
|
jpayne@68
|
273 # satisfying candidate for the requested package.
|
|
jpayne@68
|
274 # Otherwise we still have to fallback to the regular
|
|
jpayne@68
|
275 # package search to complete the processing.
|
|
jpayne@68
|
276
|
|
jpayne@68
|
277 if {($pkgname eq $name)
|
|
jpayne@68
|
278 && [package vsatisfies $pkgversion {*}$args]} {
|
|
jpayne@68
|
279 set satisfied 1
|
|
jpayne@68
|
280
|
|
jpayne@68
|
281 # We do not abort the loop, and keep adding provide
|
|
jpayne@68
|
282 # scripts for every candidate in the directory, just
|
|
jpayne@68
|
283 # remember to not fall back to the regular search
|
|
jpayne@68
|
284 # anymore.
|
|
jpayne@68
|
285 }
|
|
jpayne@68
|
286 }
|
|
jpayne@68
|
287 }
|
|
jpayne@68
|
288 }
|
|
jpayne@68
|
289
|
|
jpayne@68
|
290 if {$satisfied} {
|
|
jpayne@68
|
291 return
|
|
jpayne@68
|
292 }
|
|
jpayne@68
|
293 }
|
|
jpayne@68
|
294
|
|
jpayne@68
|
295 # Fallback to previous command, if existing. See comment above about
|
|
jpayne@68
|
296 # ::list...
|
|
jpayne@68
|
297
|
|
jpayne@68
|
298 if {[llength $original]} {
|
|
jpayne@68
|
299 uplevel 1 $original [::linsert $args 0 $name]
|
|
jpayne@68
|
300 }
|
|
jpayne@68
|
301 }
|
|
jpayne@68
|
302
|
|
jpayne@68
|
303 # ::tcl::tm::Defaults --
|
|
jpayne@68
|
304 #
|
|
jpayne@68
|
305 # Determines the default search paths.
|
|
jpayne@68
|
306 #
|
|
jpayne@68
|
307 # Arguments
|
|
jpayne@68
|
308 # None
|
|
jpayne@68
|
309 #
|
|
jpayne@68
|
310 # Results
|
|
jpayne@68
|
311 # None.
|
|
jpayne@68
|
312 #
|
|
jpayne@68
|
313 # Sideeffects
|
|
jpayne@68
|
314 # May add paths to the list of defaults.
|
|
jpayne@68
|
315
|
|
jpayne@68
|
316 proc ::tcl::tm::Defaults {} {
|
|
jpayne@68
|
317 global env tcl_platform
|
|
jpayne@68
|
318
|
|
jpayne@68
|
319 regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
|
|
jpayne@68
|
320 set exe [file normalize [info nameofexecutable]]
|
|
jpayne@68
|
321
|
|
jpayne@68
|
322 # Note that we're using [::list], not [list] because [list] means
|
|
jpayne@68
|
323 # something other than [::list] in this namespace.
|
|
jpayne@68
|
324 roots [::list \
|
|
jpayne@68
|
325 [file dirname [info library]] \
|
|
jpayne@68
|
326 [file join [file dirname [file dirname $exe]] lib] \
|
|
jpayne@68
|
327 ]
|
|
jpayne@68
|
328
|
|
jpayne@68
|
329 if {$tcl_platform(platform) eq "windows"} {
|
|
jpayne@68
|
330 set sep ";"
|
|
jpayne@68
|
331 } else {
|
|
jpayne@68
|
332 set sep ":"
|
|
jpayne@68
|
333 }
|
|
jpayne@68
|
334 for {set n $minor} {$n >= 0} {incr n -1} {
|
|
jpayne@68
|
335 foreach ev [::list \
|
|
jpayne@68
|
336 TCL${major}.${n}_TM_PATH \
|
|
jpayne@68
|
337 TCL${major}_${n}_TM_PATH \
|
|
jpayne@68
|
338 ] {
|
|
jpayne@68
|
339 if {![info exists env($ev)]} continue
|
|
jpayne@68
|
340 foreach p [split $env($ev) $sep] {
|
|
jpayne@68
|
341 path add $p
|
|
jpayne@68
|
342 }
|
|
jpayne@68
|
343 }
|
|
jpayne@68
|
344 }
|
|
jpayne@68
|
345 return
|
|
jpayne@68
|
346 }
|
|
jpayne@68
|
347
|
|
jpayne@68
|
348 # ::tcl::tm::roots --
|
|
jpayne@68
|
349 #
|
|
jpayne@68
|
350 # Public API to the module path. See specification.
|
|
jpayne@68
|
351 #
|
|
jpayne@68
|
352 # Arguments
|
|
jpayne@68
|
353 # paths - List of 'root' paths to derive search paths from.
|
|
jpayne@68
|
354 #
|
|
jpayne@68
|
355 # Results
|
|
jpayne@68
|
356 # No result.
|
|
jpayne@68
|
357 #
|
|
jpayne@68
|
358 # Sideeffects
|
|
jpayne@68
|
359 # Calls 'path add' to paths to the list of module search paths.
|
|
jpayne@68
|
360
|
|
jpayne@68
|
361 proc ::tcl::tm::roots {paths} {
|
|
jpayne@68
|
362 regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
|
|
jpayne@68
|
363 foreach pa $paths {
|
|
jpayne@68
|
364 set p [file join $pa tcl$major]
|
|
jpayne@68
|
365 for {set n $minor} {$n >= 0} {incr n -1} {
|
|
jpayne@68
|
366 set px [file join $p ${major}.${n}]
|
|
jpayne@68
|
367 if {![interp issafe]} {set px [file normalize $px]}
|
|
jpayne@68
|
368 path add $px
|
|
jpayne@68
|
369 }
|
|
jpayne@68
|
370 set px [file join $p site-tcl]
|
|
jpayne@68
|
371 if {![interp issafe]} {set px [file normalize $px]}
|
|
jpayne@68
|
372 path add $px
|
|
jpayne@68
|
373 }
|
|
jpayne@68
|
374 return
|
|
jpayne@68
|
375 }
|
|
jpayne@68
|
376
|
|
jpayne@68
|
377 # Initialization. Set up the default paths, then insert the new handler into
|
|
jpayne@68
|
378 # the chain.
|
|
jpayne@68
|
379
|
|
jpayne@68
|
380 if {![interp issafe]} {::tcl::tm::Defaults}
|
