figenc

tm.tcl (11633B)

---

 # -*- 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}