summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/init.tcl8
-rw-r--r--library/tm.tcl346
2 files changed, 353 insertions, 1 deletions
diff --git a/library/init.tcl b/library/init.tcl
index 761aa4a..7b8d4de 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.64 2004/08/18 19:59:00 kennykb Exp $
+# RCS: @(#) $Id: init.tcl,v 1.65 2004/08/18 22:03:32 andreas_kupries Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -779,3 +779,9 @@ if { ![interp issafe] } {
}
}
}
+
+# Set up search for Tcl Modules (TIP #189).
+
+if { ![interp issafe] } {
+ source [file join [file dirname [info script]] tm.tcl]
+}
diff --git a/library/tm.tcl b/library/tm.tcl
new file mode 100644
index 0000000..38e656a
--- /dev/null
+++ b/library/tm.tcl
@@ -0,0 +1,346 @@
+# -*- 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
+}
+
+# ::tcl::tm::path --
+#
+# 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::path {cmd args} {
+ variable paths
+ switch -exact -- $cmd {
+ add {
+ # 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.
+
+ if {![llength $args]} {
+ return -code error "wrong#args, expected: [lindex [info level 0] 0] add path path..."
+ }
+
+ set newpaths {}
+ foreach p $args {
+ set pos [lsearch -exact $paths $p]
+ if {$pos >= 0} {
+ # Ignore a path already on the list.
+ continue
+ }
+
+ # Search for paths which are subdirectories of the new
+ # one. If there are any then new path violates the
+ # restriction about ancestors.
+
+ set pos [lsearch -glob $paths ${p}/*]
+ if {$pos >= 0} {
+ return -code error "$p is ancestor of existing module path [lindex $paths $pos]."
+ }
+
+ # Now look for paths which are ancestors of the new
+ # one. This reverse question req us to loop over the
+ # existing paths :(
+
+ foreach ep $paths {
+ if {[string match ${ep}/* $p]} {
+ return -code error "$p is subdirectory of existing module path $ep."
+ }
+ }
+
+ lappend newpaths $p
+ }
+
+ # The validation of the input is complete and successful,
+ # and everything in newpaths is actually new. We can now
+ # extend the list of paths.
+
+ foreach p $newpaths {
+ set paths [linsert $paths 0 $p]
+ }
+ }
+ remove {
+ # Removes the path from the list of module paths. The
+ # command is silently ignored if the path is not on the
+ # list.
+
+ if {![llength $args]} {
+ return -code error "wrong#args, expected: [lindex [info level 0] 0] remove path path ..."
+ }
+
+ foreach p $args {
+ set pos [lsearch -exact $paths $p]
+ if {$pos >= 0} {
+ set paths [lreplace $paths $pos $pos]
+ }
+ }
+ }
+ list {
+ if {[llength $args]} {
+ return -code error "wrong#args, expected: [lindex [info level 0] 0] list"
+ }
+ return $paths
+ }
+ default {
+ return -code error "Expect one of add, remove, or list, got \"$cmd\""
+ }
+ }
+}
+
+# ::tcl::tm::unknown --
+#
+# 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::unknown {original name version {exact {}}} {
+ # 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 {![file exists $path]} continue
+ set currentsearchpath [file join $path $pkgroot]
+ if {![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.
+
+ package ifneeded $pkgname $pkgversion [list source $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) &&
+ ((($exact eq "-exact") && (0==[package vcompare $pkgversion $version])) ||
+ (($version ne "") && [package vsatisfies $pkgversion $version]) ||
+ ($version eq ""))
+ } {
+ 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.
+ if {[llength $original]} {
+ uplevel 1 $original [list $name $version $exact]
+ }
+}
+
+# ::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 {} {
+ foreach {major minor} [split [info tclversion] .] break
+
+ roots [list \
+ [file dirname [info library]] \
+ [file join [file dirname [file normalize [info nameofexecutable]]] lib] \
+ ]
+
+ if {$::tcl_platform(platform) eq "windows"} {
+ set sep \;
+ } else {
+ set sep :
+ }
+ for {set n $minor} {$n >= 0} {incr n -1} {
+ set ev TCL${major}.{$n}_TM_PATH
+ if {[info exists ::env($ev)]} {
+ 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} {
+ path add [file normalize [file join $p ${major}.${n}]]
+ }
+ path add [file normalize [file join $pa site-tcl]]
+ }
+ return
+}
+
+# Initialization. Set up the default paths, then insert the new
+# handler into the chain.
+
+::tcl::tm::Defaults
+package unknown [list ::tcl::tm::unknown [package unknown]]