| Server IP : 170.10.162.208 / Your IP : 216.73.216.181 Web Server : LiteSpeed System : Linux altar19.supremepanel19.com 4.18.0-553.69.1.lve.el8.x86_64 #1 SMP Wed Aug 13 19:53:59 UTC 2025 x86_64 User : deltahospital ( 1806) PHP Version : 7.4.33 Disable Function : NONE MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : ON | Sudo : OFF | Pkexec : OFF Directory : /home/deltahospital/test.delta-hospital.com/ |
Upload File : |
usr/share/tcl8.6/tm.tcl 0000644 00000026561 15053662705 0010644 0 ustar 00 # -*- 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