Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/tm.tcl @ 69:33d812a61356

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