You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
376 lines
11 KiB
376 lines
11 KiB
4 years ago
|
# -*- 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}
|