CMSCOPE changed

1 files changed, 387 insertions, 0 deletions

diff --git a/usr/lib/tcl8.5/tm.tcl b/usr/lib/tcl8.5/tm.tcl
new file mode 100755
index 000000000..7b9cafe1a
--- /dev/null
+++ b/usr/lib/tcl8.5/tm.tcl
@@ -0,0 +1,387 @@
+# -*- 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 {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
+		    }
+
+		    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} {
+    lassign [split [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 }