diff options
Diffstat (limited to 'tcl8.6/library/tm.tcl')
| -rw-r--r-- | tcl8.6/library/tm.tcl | 375 |
1 files changed, 0 insertions, 375 deletions
diff --git a/tcl8.6/library/tm.tcl b/tcl8.6/library/tm.tcl deleted file mode 100644 index 66c56a1..0000000 --- a/tcl8.6/library/tm.tcl +++ /dev/null @@ -1,375 +0,0 @@ -# -*- tcl -*- -# -# Searching for Tcl Modules. Defines a procedure, declares it as the primary -# command for finding packages, however also uses the former 'package unknown' -# command as a fallback. -# -# Locates all possible packages in a directory via a less restricted glob. The -# targeted directory is derived from the name of the requested package, i.e. -# the TM scan will look only at directories which can contain the requested -# package. It will register all packages it found in the directory so that -# future requests have a higher chance of being fulfilled by the ifneeded -# database without having to come to us again. -# -# We do not remember where we have been and simply rescan targeted directories -# when invoked again. The reasoning is this: -# -# - The only way we get back to the same directory is if someone is trying to -# [package require] something that wasn't there on the first scan. -# -# Either -# 1) It is there now: If we rescan, you get it; if not you don't. -# -# This covers the possibility that the application asked for a package -# late, and the package was actually added to the installation after the -# application was started. It shoukld still be able to find it. -# -# 2) It still is not there: Either way, you don't get it, but the rescan -# takes time. This is however an error case and we dont't care that much -# about it -# -# 3) It was there the first time; but for some reason a "package forget" has -# been run, and "package" doesn't know about it anymore. -# -# This can be an indication that the application wishes to reload some -# functionality. And should work as well. -# -# Note that this also strikes a balance between doing a glob targeting a -# single package, and thus most likely requiring multiple globs of the same -# directory when the application is asking for many packages, and trying to -# glob for _everything_ in all subdirectories when looking for a package, -# which comes with a heavy startup cost. -# -# We scan for regular packages only if no satisfying module was found. - -namespace eval ::tcl::tm { - # Default paths. None yet. - - variable paths {} - - # The regex pattern a file name has to match to make it a Tcl Module. - - set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$} - - # Export the public API - - namespace export path - namespace ensemble create -command path -subcommands {add remove list} -} - -# ::tcl::tm::path implementations -- -# -# Public API to the module path. See specification. -# -# Arguments -# cmd - The subcommand to execute -# args - The paths to add/remove. Must not appear querying the -# path with 'list'. -# -# Results -# No result for subcommands 'add' and 'remove'. A list of paths for -# 'list'. -# -# Sideeffects -# The subcommands 'add' and 'remove' manipulate the list of paths to -# search for Tcl Modules. The subcommand 'list' has no sideeffects. - -proc ::tcl::tm::add {args} { - # PART OF THE ::tcl::tm::path ENSEMBLE - # - # The path is added at the head to the list of module paths. - # - # The command enforces the restriction that no path may be an ancestor - # directory of any other path on the list. If the new path violates this - # restriction an error wil be raised. - # - # If the path is already present as is no error will be raised and no - # action will be taken. - - variable paths - - # We use a copy of the path as source during validation, and extend it as - # well. Because we not only have to detect if the new paths are bogus with - # respect to the existing paths, but also between themselves. Otherwise we - # can still add bogus paths, by specifying them in a single call. This - # makes the use of the new paths simpler as well, a trivial assignment of - # the collected paths to the official state var. - - set newpaths $paths - foreach p $args { - if {$p in $newpaths} { - # Ignore a path already on the list. - continue - } - - # Search for paths which are subdirectories of the new one. If there - # are any then the new path violates the restriction about ancestors. - - set pos [lsearch -glob $newpaths ${p}/*] - # Cannot use "in", we need the position for the message. - if {$pos >= 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 {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 $args { - 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 - } - try { - package vcompare $pkgversion 0 - } on error {} { - # Ignore everything where the version part is not - # acceptable to "package vcompare". - continue - } - - if {[package ifneeded $pkgname $pkgversion] ne {}} { - # There's already a provide script registered for - # this version of this package. Since all units of - # code claiming to be the same version of the same - # package ought to be identical, just stick with - # the one we already have. - 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]} { - 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} { - regexp {^(\d+)\.(\d+)} [package present Tcl] - major minor - 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} |