jpayne@68: # -*- tcl -*-
jpayne@68: #
jpayne@68: # Searching for Tcl Modules. Defines a procedure, declares it as the primary
jpayne@68: # command for finding packages, however also uses the former 'package unknown'
jpayne@68: # command as a fallback.
jpayne@68: #
jpayne@68: # Locates all possible packages in a directory via a less restricted glob. The
jpayne@68: # targeted directory is derived from the name of the requested package, i.e.
jpayne@68: # the TM scan will look only at directories which can contain the requested
jpayne@68: # package. It will register all packages it found in the directory so that
jpayne@68: # future requests have a higher chance of being fulfilled by the ifneeded
jpayne@68: # database without having to come to us again.
jpayne@68: #
jpayne@68: # We do not remember where we have been and simply rescan targeted directories
jpayne@68: # when invoked again. The reasoning is this:
jpayne@68: #
jpayne@68: # - The only way we get back to the same directory is if someone is trying to
jpayne@68: #   [package require] something that wasn't there on the first scan.
jpayne@68: #
jpayne@68: #   Either
jpayne@68: #   1) It is there now:  If we rescan, you get it; if not you don't.
jpayne@68: #
jpayne@68: #      This covers the possibility that the application asked for a package
jpayne@68: #      late, and the package was actually added to the installation after the
jpayne@68: #      application was started. It shoukld still be able to find it.
jpayne@68: #
jpayne@68: #   2) It still is not there: Either way, you don't get it, but the rescan
jpayne@68: #      takes time. This is however an error case and we dont't care that much
jpayne@68: #      about it
jpayne@68: #
jpayne@68: #   3) It was there the first time; but for some reason a "package forget" has
jpayne@68: #      been run, and "package" doesn't know about it anymore.
jpayne@68: #
jpayne@68: #      This can be an indication that the application wishes to reload some
jpayne@68: #      functionality. And should work as well.
jpayne@68: #
jpayne@68: # Note that this also strikes a balance between doing a glob targeting a
jpayne@68: # single package, and thus most likely requiring multiple globs of the same
jpayne@68: # directory when the application is asking for many packages, and trying to
jpayne@68: # glob for _everything_ in all subdirectories when looking for a package,
jpayne@68: # which comes with a heavy startup cost.
jpayne@68: #
jpayne@68: # We scan for regular packages only if no satisfying module was found.
jpayne@68: 
jpayne@68: namespace eval ::tcl::tm {
jpayne@68:     # Default paths. None yet.
jpayne@68: 
jpayne@68:     variable paths {}
jpayne@68: 
jpayne@68:     # The regex pattern a file name has to match to make it a Tcl Module.
jpayne@68: 
jpayne@68:     set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}
jpayne@68: 
jpayne@68:     # Export the public API
jpayne@68: 
jpayne@68:     namespace export path
jpayne@68:     namespace ensemble create -command path -subcommands {add remove list}
jpayne@68: }
jpayne@68: 
jpayne@68: # ::tcl::tm::path implementations --
jpayne@68: #
jpayne@68: #	Public API to the module path. See specification.
jpayne@68: #
jpayne@68: # Arguments
jpayne@68: #	cmd -	The subcommand to execute
jpayne@68: #	args -	The paths to add/remove. Must not appear querying the
jpayne@68: #		path with 'list'.
jpayne@68: #
jpayne@68: # Results
jpayne@68: #	No result for subcommands 'add' and 'remove'. A list of paths for
jpayne@68: #	'list'.
jpayne@68: #
jpayne@68: # Sideeffects
jpayne@68: #	The subcommands 'add' and 'remove' manipulate the list of paths to
jpayne@68: #	search for Tcl Modules. The subcommand 'list' has no sideeffects.
jpayne@68: 
jpayne@68: proc ::tcl::tm::add {args} {
jpayne@68:     # PART OF THE ::tcl::tm::path ENSEMBLE
jpayne@68:     #
jpayne@68:     # The path is added at the head to the list of module paths.
jpayne@68:     #
jpayne@68:     # The command enforces the restriction that no path may be an ancestor
jpayne@68:     # directory of any other path on the list. If the new path violates this
jpayne@68:     # restriction an error wil be raised.
jpayne@68:     #
jpayne@68:     # If the path is already present as is no error will be raised and no
jpayne@68:     # action will be taken.
jpayne@68: 
jpayne@68:     variable paths
jpayne@68: 
jpayne@68:     # We use a copy of the path as source during validation, and extend it as
jpayne@68:     # well. Because we not only have to detect if the new paths are bogus with
jpayne@68:     # respect to the existing paths, but also between themselves. Otherwise we
jpayne@68:     # can still add bogus paths, by specifying them in a single call. This
jpayne@68:     # makes the use of the new paths simpler as well, a trivial assignment of
jpayne@68:     # the collected paths to the official state var.
jpayne@68: 
jpayne@68:     set newpaths $paths
jpayne@68:     foreach p $args {
jpayne@68: 	if {$p in $newpaths} {
jpayne@68: 	    # Ignore a path already on the list.
jpayne@68: 	    continue
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	# Search for paths which are subdirectories of the new one. If there
jpayne@68: 	# are any then the new path violates the restriction about ancestors.
jpayne@68: 
jpayne@68: 	set pos [lsearch -glob $newpaths ${p}/*]
jpayne@68: 	# Cannot use "in", we need the position for the message.
jpayne@68: 	if {$pos >= 0} {
jpayne@68: 	    return -code error \
jpayne@68: 		"$p is ancestor of existing module path [lindex $newpaths $pos]."
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	# Now look for existing paths which are ancestors of the new one. This
jpayne@68: 	# reverse question forces us to loop over the existing paths, as each
jpayne@68: 	# element is the pattern, not the new path :(
jpayne@68: 
jpayne@68: 	foreach ep $newpaths {
jpayne@68: 	    if {[string match ${ep}/* $p]} {
jpayne@68: 		return -code error \
jpayne@68: 		    "$p is subdirectory of existing module path $ep."
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	set newpaths [linsert $newpaths 0 $p]
jpayne@68:     }
jpayne@68: 
jpayne@68:     # The validation of the input is complete and successful, and everything
jpayne@68:     # in newpaths is either an old path, or added. We can now extend the
jpayne@68:     # official list of paths, a simple assignment is sufficient.
jpayne@68: 
jpayne@68:     set paths $newpaths
jpayne@68:     return
jpayne@68: }
jpayne@68: 
jpayne@68: proc ::tcl::tm::remove {args} {
jpayne@68:     # PART OF THE ::tcl::tm::path ENSEMBLE
jpayne@68:     #
jpayne@68:     # Removes the path from the list of module paths. The command is silently
jpayne@68:     # ignored if the path is not on the list.
jpayne@68: 
jpayne@68:     variable paths
jpayne@68: 
jpayne@68:     foreach p $args {
jpayne@68: 	set pos [lsearch -exact $paths $p]
jpayne@68: 	if {$pos >= 0} {
jpayne@68: 	    set paths [lreplace $paths $pos $pos]
jpayne@68: 	}
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: proc ::tcl::tm::list {} {
jpayne@68:     # PART OF THE ::tcl::tm::path ENSEMBLE
jpayne@68: 
jpayne@68:     variable paths
jpayne@68:     return  $paths
jpayne@68: }
jpayne@68: 
jpayne@68: # ::tcl::tm::UnknownHandler --
jpayne@68: #
jpayne@68: #	Unknown handler for Tcl Modules, i.e. packages in module form.
jpayne@68: #
jpayne@68: # Arguments
jpayne@68: #	original	- Original [package unknown] procedure.
jpayne@68: #	name		- Name of desired package.
jpayne@68: #	version		- Version of desired package. Can be the
jpayne@68: #			  empty string.
jpayne@68: #	exact		- Either -exact or ommitted.
jpayne@68: #
jpayne@68: #	Name, version, and exact are used to determine satisfaction. The
jpayne@68: #	original is called iff no satisfaction was achieved. The name is also
jpayne@68: #	used to compute the directory to target in the search.
jpayne@68: #
jpayne@68: # Results
jpayne@68: #	None.
jpayne@68: #
jpayne@68: # Sideeffects
jpayne@68: #	May populate the package ifneeded database with additional provide
jpayne@68: #	scripts.
jpayne@68: 
jpayne@68: proc ::tcl::tm::UnknownHandler {original name args} {
jpayne@68:     # Import the list of paths to search for packages in module form.
jpayne@68:     # Import the pattern used to check package names in detail.
jpayne@68: 
jpayne@68:     variable paths
jpayne@68:     variable pkgpattern
jpayne@68: 
jpayne@68:     # Without paths to search we can do nothing. (Except falling back to the
jpayne@68:     # regular search).
jpayne@68: 
jpayne@68:     if {[llength $paths]} {
jpayne@68: 	set pkgpath [string map {:: /} $name]
jpayne@68: 	set pkgroot [file dirname $pkgpath]
jpayne@68: 	if {$pkgroot eq "."} {
jpayne@68: 	    set pkgroot ""
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	# We don't remember a copy of the paths while looping. Tcl Modules are
jpayne@68: 	# unable to change the list while we are searching for them. This also
jpayne@68: 	# simplifies the loop, as we cannot get additional directories while
jpayne@68: 	# iterating over the list. A simple foreach is sufficient.
jpayne@68: 
jpayne@68: 	set satisfied 0
jpayne@68: 	foreach path $paths {
jpayne@68: 	    if {![interp issafe] && ![file exists $path]} {
jpayne@68: 		continue
jpayne@68: 	    }
jpayne@68: 	    set currentsearchpath [file join $path $pkgroot]
jpayne@68: 	    if {![interp issafe] && ![file exists $currentsearchpath]} {
jpayne@68: 		continue
jpayne@68: 	    }
jpayne@68: 	    set strip [llength [file split $path]]
jpayne@68: 
jpayne@68: 	    # Get the module files out of the subdirectories.
jpayne@68: 	    # - Safe Base interpreters have a restricted "glob" command that
jpayne@68: 	    #   works in this case.
jpayne@68: 	    # - The "catch" was essential when there was no safe glob and every
jpayne@68: 	    #   call in a safe interp failed; it is retained only for corner
jpayne@68: 	    #   cases in which the eventual call to glob returns an error.
jpayne@68: 
jpayne@68: 	    catch {
jpayne@68: 		# We always look for _all_ possible modules in the current
jpayne@68: 		# path, to get the max result out of the glob.
jpayne@68: 
jpayne@68: 		foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
jpayne@68: 		    set pkgfilename [join [lrange [file split $file] $strip end] ::]
jpayne@68: 
jpayne@68: 		    if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
jpayne@68: 			# Ignore everything not matching our pattern for
jpayne@68: 			# package names.
jpayne@68: 			continue
jpayne@68: 		    }
jpayne@68: 		    try {
jpayne@68: 			package vcompare $pkgversion 0
jpayne@68: 		    } on error {} {
jpayne@68: 			# Ignore everything where the version part is not
jpayne@68: 			# acceptable to "package vcompare".
jpayne@68: 			continue
jpayne@68: 		    }
jpayne@68: 
jpayne@68: 		    if {([package ifneeded $pkgname $pkgversion] ne {})
jpayne@68: 			    && (![interp issafe])
jpayne@68: 		    } {
jpayne@68: 			# There's already a provide script registered for
jpayne@68: 			# this version of this package.  Since all units of
jpayne@68: 			# code claiming to be the same version of the same
jpayne@68: 			# package ought to be identical, just stick with
jpayne@68: 			# the one we already have.
jpayne@68: 			# This does not apply to Safe Base interpreters because
jpayne@68: 			# the token-to-directory mapping may have changed.
jpayne@68: 			continue
jpayne@68: 		    }
jpayne@68: 
jpayne@68: 		    # We have found a candidate, generate a "provide script"
jpayne@68: 		    # for it, and remember it.  Note that we are using ::list
jpayne@68: 		    # to do this; locally [list] means something else without
jpayne@68: 		    # the namespace specifier.
jpayne@68: 
jpayne@68: 		    # NOTE. When making changes to the format of the provide
jpayne@68: 		    # command generated below CHECK that the 'LOCATE'
jpayne@68: 		    # procedure in core file 'platform/shell.tcl' still
jpayne@68: 		    # understands it, or, if not, update its implementation
jpayne@68: 		    # appropriately.
jpayne@68: 		    #
jpayne@68: 		    # Right now LOCATE's implementation assumes that the path
jpayne@68: 		    # of the package file is the last element in the list.
jpayne@68: 
jpayne@68: 		    package ifneeded $pkgname $pkgversion \
jpayne@68: 			"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
jpayne@68: 
jpayne@68: 		    # We abort in this unknown handler only if we got a
jpayne@68: 		    # satisfying candidate for the requested package.
jpayne@68: 		    # Otherwise we still have to fallback to the regular
jpayne@68: 		    # package search to complete the processing.
jpayne@68: 
jpayne@68: 		    if {($pkgname eq $name)
jpayne@68: 			    && [package vsatisfies $pkgversion {*}$args]} {
jpayne@68: 			set satisfied 1
jpayne@68: 
jpayne@68: 			# We do not abort the loop, and keep adding provide
jpayne@68: 			# scripts for every candidate in the directory, just
jpayne@68: 			# remember to not fall back to the regular search
jpayne@68: 			# anymore.
jpayne@68: 		    }
jpayne@68: 		}
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	if {$satisfied} {
jpayne@68: 	    return
jpayne@68: 	}
jpayne@68:     }
jpayne@68: 
jpayne@68:     # Fallback to previous command, if existing.  See comment above about
jpayne@68:     # ::list...
jpayne@68: 
jpayne@68:     if {[llength $original]} {
jpayne@68: 	uplevel 1 $original [::linsert $args 0 $name]
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: # ::tcl::tm::Defaults --
jpayne@68: #
jpayne@68: #	Determines the default search paths.
jpayne@68: #
jpayne@68: # Arguments
jpayne@68: #	None
jpayne@68: #
jpayne@68: # Results
jpayne@68: #	None.
jpayne@68: #
jpayne@68: # Sideeffects
jpayne@68: #	May add paths to the list of defaults.
jpayne@68: 
jpayne@68: proc ::tcl::tm::Defaults {} {
jpayne@68:     global env tcl_platform
jpayne@68: 
jpayne@68:     regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
jpayne@68:     set exe [file normalize [info nameofexecutable]]
jpayne@68: 
jpayne@68:     # Note that we're using [::list], not [list] because [list] means
jpayne@68:     # something other than [::list] in this namespace.
jpayne@68:     roots [::list \
jpayne@68: 	    [file dirname [info library]] \
jpayne@68: 	    [file join [file dirname [file dirname $exe]] lib] \
jpayne@68: 	    ]
jpayne@68: 
jpayne@68:     if {$tcl_platform(platform) eq "windows"} {
jpayne@68: 	set sep ";"
jpayne@68:     } else {
jpayne@68: 	set sep ":"
jpayne@68:     }
jpayne@68:     for {set n $minor} {$n >= 0} {incr n -1} {
jpayne@68: 	foreach ev [::list \
jpayne@68: 			TCL${major}.${n}_TM_PATH \
jpayne@68: 			TCL${major}_${n}_TM_PATH \
jpayne@68:         ] {
jpayne@68: 	    if {![info exists env($ev)]} continue
jpayne@68: 	    foreach p [split $env($ev) $sep] {
jpayne@68: 		path add $p
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68:     }
jpayne@68:     return
jpayne@68: }
jpayne@68: 
jpayne@68: # ::tcl::tm::roots --
jpayne@68: #
jpayne@68: #	Public API to the module path. See specification.
jpayne@68: #
jpayne@68: # Arguments
jpayne@68: #	paths -	List of 'root' paths to derive search paths from.
jpayne@68: #
jpayne@68: # Results
jpayne@68: #	No result.
jpayne@68: #
jpayne@68: # Sideeffects
jpayne@68: #	Calls 'path add' to paths to the list of module search paths.
jpayne@68: 
jpayne@68: proc ::tcl::tm::roots {paths} {
jpayne@68:     regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
jpayne@68:     foreach pa $paths {
jpayne@68: 	set p [file join $pa tcl$major]
jpayne@68: 	for {set n $minor} {$n >= 0} {incr n -1} {
jpayne@68: 	    set px [file join $p ${major}.${n}]
jpayne@68: 	    if {![interp issafe]} {set px [file normalize $px]}
jpayne@68: 	    path add $px
jpayne@68: 	}
jpayne@68: 	set px [file join $p site-tcl]
jpayne@68: 	if {![interp issafe]} {set px [file normalize $px]}
jpayne@68: 	path add $px
jpayne@68:     }
jpayne@68:     return
jpayne@68: }
jpayne@68: 
jpayne@68: # Initialization. Set up the default paths, then insert the new handler into
jpayne@68: # the chain.
jpayne@68: 
jpayne@68: if {![interp issafe]} {::tcl::tm::Defaults}