1# -*- tcl -*- 2# 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. 6# 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. 14# 15# We do not remember where we have been and simply rescan targeted 16# directories when invoked again. The reasoning is this: 17# 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 20# first scan. 21# 22# Either 23# 1) It is there now: If we rescan, you get it; if not you don't. 24# 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. 29# 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 33# 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 36# anymore. 37# 38# This can be an indication that the application wishes to reload 39# some functionality. And should work as well. 40# 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. 46# 47# We scan for regular packages only if no satisfying module was found. 48 49namespace eval ::tcl::tm { 50 # Default paths. None yet. 51 52 variable paths {} 53 54 # The regex pattern a file name has to match to make it a Tcl Module. 55 56 set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$} 57 58 # Export the public API 59 60 namespace export path 61 namespace ensemble create -command path -subcommand {add remove list} 62} 63 64# ::tcl::tm::path implementations -- 65# 66# Public API to the module path. See specification. 67# 68# Arguments 69# cmd - The subcommand to execute 70# args - The paths to add/remove. Must not appear querying the 71# path with 'list'. 72# 73# Results 74# No result for subcommands 'add' and 'remove'. A list of paths 75# for 'list'. 76# 77# Sideeffects 78# The subcommands 'add' and 'remove' manipulate the list of 79# paths to search for Tcl Modules. The subcommand 'list' has no 80# sideeffects. 81 82proc ::tcl::tm::add {path args} { 83 # PART OF THE ::tcl::tm::path ENSEMBLE 84 # 85 # The path is added at the head to the list of module paths. 86 # 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. 90 # 91 # If the path is already present as is no error will be raised and 92 # no action will be taken. 93 94 variable paths 95 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. 103 104 set newpaths $paths 105 foreach p [linsert $args 0 $path] { 106 if {$p in $newpaths} { 107 # Ignore a path already on the list. 108 continue 109 } 110 111 # Search for paths which are subdirectories of the new one. If 112 # there are any then the new path violates the restriction 113 # about ancestors. 114 115 set pos [lsearch -glob $newpaths ${p}/*] 116 # Cannot use "in", we need the position for the message. 117 if {$pos >= 0} { 118 return -code error \ 119 "$p is ancestor of existing module path [lindex $newpaths $pos]." 120 } 121 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 125 # path :( 126 127 foreach ep $newpaths { 128 if {[string match ${ep}/* $p]} { 129 return -code error \ 130 "$p is subdirectory of existing module path $ep." 131 } 132 } 133 134 set newpaths [linsert $newpaths 0 $p] 135 } 136 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 140 # sufficient. 141 142 set paths $newpaths 143 return 144} 145 146proc ::tcl::tm::remove {path args} { 147 # PART OF THE ::tcl::tm::path ENSEMBLE 148 # 149 # Removes the path from the list of module paths. The command is 150 # silently ignored if the path is not on the list. 151 152 variable paths 153 154 foreach p [linsert $args 0 $path] { 155 set pos [lsearch -exact $paths $p] 156 if {$pos >= 0} { 157 set paths [lreplace $paths $pos $pos] 158 } 159 } 160} 161 162proc ::tcl::tm::list {} { 163 # PART OF THE ::tcl::tm::path ENSEMBLE 164 165 variable paths 166 return $paths 167} 168 169# ::tcl::tm::UnknownHandler -- 170# 171# Unknown handler for Tcl Modules, i.e. packages in module form. 172# 173# Arguments 174# original - Original [package unknown] procedure. 175# name - Name of desired package. 176# version - Version of desired package. Can be the 177# empty string. 178# exact - Either -exact or ommitted. 179# 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. 184# 185# Results 186# None. 187# 188# Sideeffects 189# May populate the package ifneeded database with additional 190# provide scripts. 191 192proc ::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. 195 196 variable paths 197 variable pkgpattern 198 199 # Without paths to search we can do nothing. (Except falling back 200 # to the regular search). 201 202 if {[llength $paths]} { 203 set pkgpath [string map {:: /} $name] 204 set pkgroot [file dirname $pkgpath] 205 if {$pkgroot eq "."} { 206 set pkgroot "" 207 } 208 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. 214 215 set satisfied 0 216 foreach path $paths { 217 if {![interp issafe] && ![file exists $path]} { 218 continue 219 } 220 set currentsearchpath [file join $path $pkgroot] 221 if {![interp issafe] && ![file exists $currentsearchpath]} { 222 continue 223 } 224 set strip [llength [file split $path]] 225 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 231 # regular packages. 232 233 catch { 234 # We always look for _all_ possible modules in the current 235 # path, to get the max result out of the glob. 236 237 foreach file [glob -nocomplain -directory $currentsearchpath *.tm] { 238 set pkgfilename [join [lrange [file split $file] $strip end] ::] 239 240 if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { 241 # Ignore everything not matching our pattern 242 # for package names. 243 continue 244 } 245 if {[catch {package vcompare $pkgversion 0}]} { 246 # Ignore everything where the version part is 247 # not acceptable to "package vcompare". 248 continue 249 } 250 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 255 # specifier. 256 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. 262 # 263 # Right now LOCATE's implementation assumes that 264 # the path of the package file is the last element 265 # in the list. 266 267 package ifneeded $pkgname $pkgversion \ 268 "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]" 269 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 274 # processing. 275 276 if { 277 ($pkgname eq $name) && 278 [package vsatisfies $pkgversion {*}$args] 279 } then { 280 set satisfied 1 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. 285 } 286 } 287 } 288 } 289 290 if {$satisfied} { 291 return 292 } 293 } 294 295 # Fallback to previous command, if existing. See comment above 296 # about ::list... 297 298 if {[llength $original]} { 299 uplevel 1 $original [::linsert $args 0 $name] 300 } 301} 302 303# ::tcl::tm::Defaults -- 304# 305# Determines the default search paths. 306# 307# Arguments 308# None 309# 310# Results 311# None. 312# 313# Sideeffects 314# May add paths to the list of defaults. 315 316proc ::tcl::tm::Defaults {} { 317 global env tcl_platform 318 319 lassign [split [info tclversion] .] major minor 320 set exe [file normalize [info nameofexecutable]] 321 322 # Note that we're using [::list], not [list] because [list] means 323 # something other than [::list] in this namespace. 324 roots [::list \ 325 [file dirname [info library]] \ 326 [file join [file dirname [file dirname $exe]] lib] \ 327 ] 328 329 if {$tcl_platform(platform) eq "windows"} { 330 set sep ";" 331 } else { 332 set sep ":" 333 } 334 for {set n $minor} {$n >= 0} {incr n -1} { 335 foreach ev [::list \ 336 TCL${major}.${n}_TM_PATH \ 337 TCL${major}_${n}_TM_PATH \ 338 ] { 339 if {![info exists env($ev)]} continue 340 foreach p [split $env($ev) $sep] { 341 path add $p 342 } 343 } 344 } 345 return 346} 347 348# ::tcl::tm::roots -- 349# 350# Public API to the module path. See specification. 351# 352# Arguments 353# paths - List of 'root' paths to derive search paths from. 354# 355# Results 356# No result. 357# 358# Sideeffects 359# Calls 'path add' to paths to the list of module search paths. 360 361proc ::tcl::tm::roots {paths} { 362 foreach {major minor} [split [info tclversion] .] break 363 foreach pa $paths { 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] } 368 path add $px 369 } 370 set px [file join $p site-tcl] 371 if {![interp issafe]} { set px [file normalize $px] } 372 path add $px 373 } 374 return 375} 376 377# Initialization. Set up the default paths, then insert the new 378# handler into the chain. 379 380if {![interp issafe]} { ::tcl::tm::Defaults } 381