Initial commit
This commit is contained in:
380
ruby/lib/tcltk/tcl8.5/tm.tcl
Normal file
380
ruby/lib/tcltk/tcl8.5/tm.tcl
Normal file
@@ -0,0 +1,380 @@
|
||||
# -*- 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 -subcommand {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 {path 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 [linsert $args 0 $path] {
|
||||
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 {path 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 [linsert $args 0 $path] {
|
||||
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
|
||||
}
|
||||
if {[catch {package vcompare $pkgversion 0}]} {
|
||||
# Ignore everything where the version part is
|
||||
# not acceptable to "package vcompare".
|
||||
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]
|
||||
} then {
|
||||
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} {
|
||||
foreach {major minor} [split [info tclversion] .] break
|
||||
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 }
|
||||
Reference in New Issue
Block a user