summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl')
-rw-r--r--Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl375
1 files changed, 375 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl b/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl
new file mode 100644
index 00000000000..1802bb901d8
--- /dev/null
+++ b/Master/tlpkg/tltcl/lib/tcl8.6/tm.tcl
@@ -0,0 +1,375 @@
+# -*- 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
+
+ regexp {^(\d+)\.(\d+)} [package provide Tcl] - 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 provide 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}