jpayne@68: # package.tcl --
jpayne@68: #
jpayne@68: # utility procs formerly in init.tcl which can be loaded on demand
jpayne@68: # for package management.
jpayne@68: #
jpayne@68: # Copyright (c) 1991-1993 The Regents of the University of California.
jpayne@68: # Copyright (c) 1994-1998 Sun Microsystems, Inc.
jpayne@68: #
jpayne@68: # See the file "license.terms" for information on usage and redistribution
jpayne@68: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
jpayne@68: #
jpayne@68: 
jpayne@68: namespace eval tcl::Pkg {}
jpayne@68: 
jpayne@68: # ::tcl::Pkg::CompareExtension --
jpayne@68: #
jpayne@68: # Used internally by pkg_mkIndex to compare the extension of a file to a given
jpayne@68: # extension. On Windows, it uses a case-insensitive comparison because the
jpayne@68: # file system can be file insensitive.
jpayne@68: #
jpayne@68: # Arguments:
jpayne@68: #  fileName	name of a file whose extension is compared
jpayne@68: #  ext		(optional) The extension to compare against; you must
jpayne@68: #		provide the starting dot.
jpayne@68: #		Defaults to [info sharedlibextension]
jpayne@68: #
jpayne@68: # Results:
jpayne@68: #  Returns 1 if the extension matches, 0 otherwise
jpayne@68: 
jpayne@68: proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
jpayne@68:     global tcl_platform
jpayne@68:     if {$ext eq ""} {set ext [info sharedlibextension]}
jpayne@68:     if {$tcl_platform(platform) eq "windows"} {
jpayne@68:         return [string equal -nocase [file extension $fileName] $ext]
jpayne@68:     } else {
jpayne@68:         # Some unices add trailing numbers after the .so, so
jpayne@68:         # we could have something like '.so.1.2'.
jpayne@68:         set root $fileName
jpayne@68:         while {1} {
jpayne@68:             set currExt [file extension $root]
jpayne@68:             if {$currExt eq $ext} {
jpayne@68:                 return 1
jpayne@68:             }
jpayne@68: 
jpayne@68: 	    # The current extension does not match; if it is not a numeric
jpayne@68: 	    # value, quit, as we are only looking to ignore version number
jpayne@68: 	    # extensions.  Otherwise we might return 1 in this case:
jpayne@68: 	    #		tcl::Pkg::CompareExtension foo.so.bar .so
jpayne@68: 	    # which should not match.
jpayne@68: 
jpayne@68: 	    if {![string is integer -strict [string range $currExt 1 end]]} {
jpayne@68: 		return 0
jpayne@68: 	    }
jpayne@68:             set root [file rootname $root]
jpayne@68: 	}
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: # pkg_mkIndex --
jpayne@68: # This procedure creates a package index in a given directory.  The package
jpayne@68: # index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that
jpayne@68: # sets up package information with "package require" commands.  The commands
jpayne@68: # describe all of the packages defined by the files given as arguments.
jpayne@68: #
jpayne@68: # Arguments:
jpayne@68: # -direct		(optional) If this flag is present, the generated
jpayne@68: #			code in pkgMkIndex.tcl will cause the package to be
jpayne@68: #			loaded when "package require" is executed, rather
jpayne@68: #			than lazily when the first reference to an exported
jpayne@68: #			procedure in the package is made.
jpayne@68: # -verbose		(optional) Verbose output; the name of each file that
jpayne@68: #			was successfully rocessed is printed out. Additionally,
jpayne@68: #			if processing of a file failed a message is printed.
jpayne@68: # -load pat		(optional) Preload any packages whose names match
jpayne@68: #			the pattern.  Used to handle DLLs that depend on
jpayne@68: #			other packages during their Init procedure.
jpayne@68: # dir -			Name of the directory in which to create the index.
jpayne@68: # args -		Any number of additional arguments, each giving
jpayne@68: #			a glob pattern that matches the names of one or
jpayne@68: #			more shared libraries or Tcl script files in
jpayne@68: #			dir.
jpayne@68: 
jpayne@68: proc pkg_mkIndex {args} {
jpayne@68:     set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"}
jpayne@68: 
jpayne@68:     set argCount [llength $args]
jpayne@68:     if {$argCount < 1} {
jpayne@68: 	return -code error "wrong # args: should be\n$usage"
jpayne@68:     }
jpayne@68: 
jpayne@68:     set more ""
jpayne@68:     set direct 1
jpayne@68:     set doVerbose 0
jpayne@68:     set loadPat ""
jpayne@68:     for {set idx 0} {$idx < $argCount} {incr idx} {
jpayne@68: 	set flag [lindex $args $idx]
jpayne@68: 	switch -glob -- $flag {
jpayne@68: 	    -- {
jpayne@68: 		# done with the flags
jpayne@68: 		incr idx
jpayne@68: 		break
jpayne@68: 	    }
jpayne@68: 	    -verbose {
jpayne@68: 		set doVerbose 1
jpayne@68: 	    }
jpayne@68: 	    -lazy {
jpayne@68: 		set direct 0
jpayne@68: 		append more " -lazy"
jpayne@68: 	    }
jpayne@68: 	    -direct {
jpayne@68: 		append more " -direct"
jpayne@68: 	    }
jpayne@68: 	    -load {
jpayne@68: 		incr idx
jpayne@68: 		set loadPat [lindex $args $idx]
jpayne@68: 		append more " -load $loadPat"
jpayne@68: 	    }
jpayne@68: 	    -* {
jpayne@68: 		return -code error "unknown flag $flag: should be\n$usage"
jpayne@68: 	    }
jpayne@68: 	    default {
jpayne@68: 		# done with the flags
jpayne@68: 		break
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68:     }
jpayne@68: 
jpayne@68:     set dir [lindex $args $idx]
jpayne@68:     set patternList [lrange $args [expr {$idx + 1}] end]
jpayne@68:     if {![llength $patternList]} {
jpayne@68: 	set patternList [list "*.tcl" "*[info sharedlibextension]"]
jpayne@68:     }
jpayne@68: 
jpayne@68:     try {
jpayne@68: 	set fileList [glob -directory $dir -tails -types {r f} -- \
jpayne@68: 		{*}$patternList]
jpayne@68:     } on error {msg opt} {
jpayne@68: 	return -options $opt $msg
jpayne@68:     }
jpayne@68:     foreach file $fileList {
jpayne@68: 	# For each file, figure out what commands and packages it provides.
jpayne@68: 	# To do this, create a child interpreter, load the file into the
jpayne@68: 	# interpreter, and get a list of the new commands and packages that
jpayne@68: 	# are defined.
jpayne@68: 
jpayne@68: 	if {$file eq "pkgIndex.tcl"} {
jpayne@68: 	    continue
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	set c [interp create]
jpayne@68: 
jpayne@68: 	# Load into the child any packages currently loaded in the parent
jpayne@68: 	# interpreter that match the -load pattern.
jpayne@68: 
jpayne@68: 	if {$loadPat ne ""} {
jpayne@68: 	    if {$doVerbose} {
jpayne@68: 		tclLog "currently loaded packages: '[info loaded]'"
jpayne@68: 		tclLog "trying to load all packages matching $loadPat"
jpayne@68: 	    }
jpayne@68: 	    if {![llength [info loaded]]} {
jpayne@68: 		tclLog "warning: no packages are currently loaded, nothing"
jpayne@68: 		tclLog "can possibly match '$loadPat'"
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	foreach pkg [info loaded] {
jpayne@68: 	    if {![string match -nocase $loadPat [lindex $pkg 1]]} {
jpayne@68: 		continue
jpayne@68: 	    }
jpayne@68: 	    if {$doVerbose} {
jpayne@68: 		tclLog "package [lindex $pkg 1] matches '$loadPat'"
jpayne@68: 	    }
jpayne@68: 	    try {
jpayne@68: 		load [lindex $pkg 0] [lindex $pkg 1] $c
jpayne@68: 	    } on error err {
jpayne@68: 		if {$doVerbose} {
jpayne@68: 		    tclLog "warning: load [lindex $pkg 0]\
jpayne@68: 			    [lindex $pkg 1]\nfailed with: $err"
jpayne@68: 		}
jpayne@68: 	    } on ok {} {
jpayne@68: 		if {$doVerbose} {
jpayne@68: 		    tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
jpayne@68: 		}
jpayne@68: 	    }
jpayne@68: 	    if {[lindex $pkg 1] eq "Tk"} {
jpayne@68: 		# Withdraw . if Tk was loaded, to avoid showing a window.
jpayne@68: 		$c eval [list wm withdraw .]
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	$c eval {
jpayne@68: 	    # Stub out the package command so packages can require other
jpayne@68: 	    # packages.
jpayne@68: 
jpayne@68: 	    rename package __package_orig
jpayne@68: 	    proc package {what args} {
jpayne@68: 		switch -- $what {
jpayne@68: 		    require {
jpayne@68: 			return;		# Ignore transitive requires
jpayne@68: 		    }
jpayne@68: 		    default {
jpayne@68: 			__package_orig $what {*}$args
jpayne@68: 		    }
jpayne@68: 		}
jpayne@68: 	    }
jpayne@68: 	    proc tclPkgUnknown args {}
jpayne@68: 	    package unknown tclPkgUnknown
jpayne@68: 
jpayne@68: 	    # Stub out the unknown command so package can call into each other
jpayne@68: 	    # during their initialilzation.
jpayne@68: 
jpayne@68: 	    proc unknown {args} {}
jpayne@68: 
jpayne@68: 	    # Stub out the auto_import mechanism
jpayne@68: 
jpayne@68: 	    proc auto_import {args} {}
jpayne@68: 
jpayne@68: 	    # reserve the ::tcl namespace for support procs and temporary
jpayne@68: 	    # variables.  This might make it awkward to generate a
jpayne@68: 	    # pkgIndex.tcl file for the ::tcl namespace.
jpayne@68: 
jpayne@68: 	    namespace eval ::tcl {
jpayne@68: 		variable dir		;# Current directory being processed
jpayne@68: 		variable file		;# Current file being processed
jpayne@68: 		variable direct		;# -direct flag value
jpayne@68: 		variable x		;# Loop variable
jpayne@68: 		variable debug		;# For debugging
jpayne@68: 		variable type		;# "load" or "source", for -direct
jpayne@68: 		variable namespaces	;# Existing namespaces (e.g., ::tcl)
jpayne@68: 		variable packages	;# Existing packages (e.g., Tcl)
jpayne@68: 		variable origCmds	;# Existing commands
jpayne@68: 		variable newCmds	;# Newly created commands
jpayne@68: 		variable newPkgs {}	;# Newly created packages
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	$c eval [list set ::tcl::dir $dir]
jpayne@68: 	$c eval [list set ::tcl::file $file]
jpayne@68: 	$c eval [list set ::tcl::direct $direct]
jpayne@68: 
jpayne@68: 	# Download needed procedures into the child because we've just deleted
jpayne@68: 	# the unknown procedure.  This doesn't handle procedures with default
jpayne@68: 	# arguments.
jpayne@68: 
jpayne@68: 	foreach p {::tcl::Pkg::CompareExtension} {
jpayne@68: 	    $c eval [list namespace eval [namespace qualifiers $p] {}]
jpayne@68: 	    $c eval [list proc $p [info args $p] [info body $p]]
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	try {
jpayne@68: 	    $c eval {
jpayne@68: 		set ::tcl::debug "loading or sourcing"
jpayne@68: 
jpayne@68: 		# we need to track command defined by each package even in the
jpayne@68: 		# -direct case, because they are needed internally by the
jpayne@68: 		# "partial pkgIndex.tcl" step above.
jpayne@68: 
jpayne@68: 		proc ::tcl::GetAllNamespaces {{root ::}} {
jpayne@68: 		    set list $root
jpayne@68: 		    foreach ns [namespace children $root] {
jpayne@68: 			lappend list {*}[::tcl::GetAllNamespaces $ns]
jpayne@68: 		    }
jpayne@68: 		    return $list
jpayne@68: 		}
jpayne@68: 
jpayne@68: 		# init the list of existing namespaces, packages, commands
jpayne@68: 
jpayne@68: 		foreach ::tcl::x [::tcl::GetAllNamespaces] {
jpayne@68: 		    set ::tcl::namespaces($::tcl::x) 1
jpayne@68: 		}
jpayne@68: 		foreach ::tcl::x [package names] {
jpayne@68: 		    if {[package provide $::tcl::x] ne ""} {
jpayne@68: 			set ::tcl::packages($::tcl::x) 1
jpayne@68: 		    }
jpayne@68: 		}
jpayne@68: 		set ::tcl::origCmds [info commands]
jpayne@68: 
jpayne@68: 		# Try to load the file if it has the shared library extension,
jpayne@68: 		# otherwise source it.  It's important not to try to load
jpayne@68: 		# files that aren't shared libraries, because on some systems
jpayne@68: 		# (like SunOS) the loader will abort the whole application
jpayne@68: 		# when it gets an error.
jpayne@68: 
jpayne@68: 		if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension]]} {
jpayne@68: 		    # The "file join ." command below is necessary.  Without
jpayne@68: 		    # it, if the file name has no \'s and we're on UNIX, the
jpayne@68: 		    # load command will invoke the LD_LIBRARY_PATH search
jpayne@68: 		    # mechanism, which could cause the wrong file to be used.
jpayne@68: 
jpayne@68: 		    set ::tcl::debug loading
jpayne@68: 		    load [file join $::tcl::dir $::tcl::file]
jpayne@68: 		    set ::tcl::type load
jpayne@68: 		} else {
jpayne@68: 		    set ::tcl::debug sourcing
jpayne@68: 		    source [file join $::tcl::dir $::tcl::file]
jpayne@68: 		    set ::tcl::type source
jpayne@68: 		}
jpayne@68: 
jpayne@68: 		# As a performance optimization, if we are creating direct
jpayne@68: 		# load packages, don't bother figuring out the set of commands
jpayne@68: 		# created by the new packages.  We only need that list for
jpayne@68: 		# setting up the autoloading used in the non-direct case.
jpayne@68: 		if {!$::tcl::direct} {
jpayne@68: 		    # See what new namespaces appeared, and import commands
jpayne@68: 		    # from them.  Only exported commands go into the index.
jpayne@68: 
jpayne@68: 		    foreach ::tcl::x [::tcl::GetAllNamespaces] {
jpayne@68: 			if {![info exists ::tcl::namespaces($::tcl::x)]} {
jpayne@68: 			    namespace import -force ${::tcl::x}::*
jpayne@68: 			}
jpayne@68: 
jpayne@68: 			# Figure out what commands appeared
jpayne@68: 
jpayne@68: 			foreach ::tcl::x [info commands] {
jpayne@68: 			    set ::tcl::newCmds($::tcl::x) 1
jpayne@68: 			}
jpayne@68: 			foreach ::tcl::x $::tcl::origCmds {
jpayne@68: 			    unset -nocomplain ::tcl::newCmds($::tcl::x)
jpayne@68: 			}
jpayne@68: 			foreach ::tcl::x [array names ::tcl::newCmds] {
jpayne@68: 			    # determine which namespace a command comes from
jpayne@68: 
jpayne@68: 			    set ::tcl::abs [namespace origin $::tcl::x]
jpayne@68: 
jpayne@68: 			    # special case so that global names have no
jpayne@68: 			    # leading ::, this is required by the unknown
jpayne@68: 			    # command
jpayne@68: 
jpayne@68: 			    set ::tcl::abs \
jpayne@68: 				    [lindex [auto_qualify $::tcl::abs ::] 0]
jpayne@68: 
jpayne@68: 			    if {$::tcl::x ne $::tcl::abs} {
jpayne@68: 				# Name changed during qualification
jpayne@68: 
jpayne@68: 				set ::tcl::newCmds($::tcl::abs) 1
jpayne@68: 				unset ::tcl::newCmds($::tcl::x)
jpayne@68: 			    }
jpayne@68: 			}
jpayne@68: 		    }
jpayne@68: 		}
jpayne@68: 
jpayne@68: 		# Look through the packages that appeared, and if there is a
jpayne@68: 		# version provided, then record it
jpayne@68: 
jpayne@68: 		foreach ::tcl::x [package names] {
jpayne@68: 		    if {[package provide $::tcl::x] ne ""
jpayne@68: 			    && ![info exists ::tcl::packages($::tcl::x)]} {
jpayne@68: 			lappend ::tcl::newPkgs \
jpayne@68: 			    [list $::tcl::x [package provide $::tcl::x]]
jpayne@68: 		    }
jpayne@68: 		}
jpayne@68: 	    }
jpayne@68: 	} on error msg {
jpayne@68: 	    set what [$c eval set ::tcl::debug]
jpayne@68: 	    if {$doVerbose} {
jpayne@68: 		tclLog "warning: error while $what $file: $msg"
jpayne@68: 	    }
jpayne@68: 	} on ok {} {
jpayne@68: 	    set what [$c eval set ::tcl::debug]
jpayne@68: 	    if {$doVerbose} {
jpayne@68: 		tclLog "successful $what of $file"
jpayne@68: 	    }
jpayne@68: 	    set type [$c eval set ::tcl::type]
jpayne@68: 	    set cmds [lsort [$c eval array names ::tcl::newCmds]]
jpayne@68: 	    set pkgs [$c eval set ::tcl::newPkgs]
jpayne@68: 	    if {$doVerbose} {
jpayne@68: 		if {!$direct} {
jpayne@68: 		    tclLog "commands provided were $cmds"
jpayne@68: 		}
jpayne@68: 		tclLog "packages provided were $pkgs"
jpayne@68: 	    }
jpayne@68: 	    if {[llength $pkgs] > 1} {
jpayne@68: 		tclLog "warning: \"$file\" provides more than one package ($pkgs)"
jpayne@68: 	    }
jpayne@68: 	    foreach pkg $pkgs {
jpayne@68: 		# cmds is empty/not used in the direct case
jpayne@68: 		lappend files($pkg) [list $file $type $cmds]
jpayne@68: 	    }
jpayne@68: 
jpayne@68: 	    if {$doVerbose} {
jpayne@68: 		tclLog "processed $file"
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	interp delete $c
jpayne@68:     }
jpayne@68: 
jpayne@68:     append index "# Tcl package index file, version 1.1\n"
jpayne@68:     append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
jpayne@68:     append index "# and sourced either when an application starts up or\n"
jpayne@68:     append index "# by a \"package unknown\" script.  It invokes the\n"
jpayne@68:     append index "# \"package ifneeded\" command to set up package-related\n"
jpayne@68:     append index "# information so that packages will be loaded automatically\n"
jpayne@68:     append index "# in response to \"package require\" commands.  When this\n"
jpayne@68:     append index "# script is sourced, the variable \$dir must contain the\n"
jpayne@68:     append index "# full path name of this file's directory.\n"
jpayne@68: 
jpayne@68:     foreach pkg [lsort [array names files]] {
jpayne@68: 	set cmd {}
jpayne@68: 	lassign $pkg name version
jpayne@68: 	lappend cmd ::tcl::Pkg::Create -name $name -version $version
jpayne@68: 	foreach spec [lsort -index 0 $files($pkg)] {
jpayne@68: 	    foreach {file type procs} $spec {
jpayne@68: 		if {$direct} {
jpayne@68: 		    set procs {}
jpayne@68: 		}
jpayne@68: 		lappend cmd "-$type" [list $file $procs]
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	append index "\n[eval $cmd]"
jpayne@68:     }
jpayne@68: 
jpayne@68:     set f [open [file join $dir pkgIndex.tcl] w]
jpayne@68:     puts $f $index
jpayne@68:     close $f
jpayne@68: }
jpayne@68: 
jpayne@68: # tclPkgSetup --
jpayne@68: # This is a utility procedure use by pkgIndex.tcl files.  It is invoked as
jpayne@68: # part of a "package ifneeded" script.  It calls "package provide" to indicate
jpayne@68: # that a package is available, then sets entries in the auto_index array so
jpayne@68: # that the package's files will be auto-loaded when the commands are used.
jpayne@68: #
jpayne@68: # Arguments:
jpayne@68: # dir -			Directory containing all the files for this package.
jpayne@68: # pkg -			Name of the package (no version number).
jpayne@68: # version -		Version number for the package, such as 2.1.3.
jpayne@68: # files -		List of files that constitute the package.  Each
jpayne@68: #			element is a sub-list with three elements.  The first
jpayne@68: #			is the name of a file relative to $dir, the second is
jpayne@68: #			"load" or "source", indicating whether the file is a
jpayne@68: #			loadable binary or a script to source, and the third
jpayne@68: #			is a list of commands defined by this file.
jpayne@68: 
jpayne@68: proc tclPkgSetup {dir pkg version files} {
jpayne@68:     global auto_index
jpayne@68: 
jpayne@68:     package provide $pkg $version
jpayne@68:     foreach fileInfo $files {
jpayne@68: 	set f [lindex $fileInfo 0]
jpayne@68: 	set type [lindex $fileInfo 1]
jpayne@68: 	foreach cmd [lindex $fileInfo 2] {
jpayne@68: 	    if {$type eq "load"} {
jpayne@68: 		set auto_index($cmd) [list load [file join $dir $f] $pkg]
jpayne@68: 	    } else {
jpayne@68: 		set auto_index($cmd) [list source [file join $dir $f]]
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: # tclPkgUnknown --
jpayne@68: # This procedure provides the default for the "package unknown" function.  It
jpayne@68: # is invoked when a package that's needed can't be found.  It scans the
jpayne@68: # auto_path directories and their immediate children looking for pkgIndex.tcl
jpayne@68: # files and sources any such files that are found to setup the package
jpayne@68: # database. As it searches, it will recognize changes to the auto_path and
jpayne@68: # scan any new directories.
jpayne@68: #
jpayne@68: # Arguments:
jpayne@68: # name -		Name of desired package.  Not used.
jpayne@68: # version -		Version of desired package.  Not used.
jpayne@68: # exact -		Either "-exact" or omitted.  Not used.
jpayne@68: 
jpayne@68: proc tclPkgUnknown {name args} {
jpayne@68:     global auto_path env
jpayne@68: 
jpayne@68:     if {![info exists auto_path]} {
jpayne@68: 	return
jpayne@68:     }
jpayne@68:     # Cache the auto_path, because it may change while we run through the
jpayne@68:     # first set of pkgIndex.tcl files
jpayne@68:     set old_path [set use_path $auto_path]
jpayne@68:     while {[llength $use_path]} {
jpayne@68: 	set dir [lindex $use_path end]
jpayne@68: 
jpayne@68: 	# Make sure we only scan each directory one time.
jpayne@68: 	if {[info exists tclSeenPath($dir)]} {
jpayne@68: 	    set use_path [lrange $use_path 0 end-1]
jpayne@68: 	    continue
jpayne@68: 	}
jpayne@68: 	set tclSeenPath($dir) 1
jpayne@68: 
jpayne@68: 	# Get the pkgIndex.tcl files in subdirectories of auto_path directories.
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: 	catch {
jpayne@68: 	    foreach file [glob -directory $dir -join -nocomplain \
jpayne@68: 		    * pkgIndex.tcl] {
jpayne@68: 		set dir [file dirname $file]
jpayne@68: 		if {![info exists procdDirs($dir)]} {
jpayne@68: 		    try {
jpayne@68: 			source $file
jpayne@68: 		    } trap {POSIX EACCES} {} {
jpayne@68: 			# $file was not readable; silently ignore
jpayne@68: 			continue
jpayne@68: 		    } on error msg {
jpayne@68: 			tclLog "error reading package index file $file: $msg"
jpayne@68: 		    } on ok {} {
jpayne@68: 			set procdDirs($dir) 1
jpayne@68: 		    }
jpayne@68: 		}
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	set dir [lindex $use_path end]
jpayne@68: 	if {![info exists procdDirs($dir)]} {
jpayne@68: 	    set file [file join $dir pkgIndex.tcl]
jpayne@68: 	    # safe interps usually don't have "file exists",
jpayne@68: 	    if {([interp issafe] || [file exists $file])} {
jpayne@68: 		try {
jpayne@68: 		    source $file
jpayne@68: 		} trap {POSIX EACCES} {} {
jpayne@68: 		    # $file was not readable; silently ignore
jpayne@68: 		    continue
jpayne@68: 		} on error msg {
jpayne@68: 		    tclLog "error reading package index file $file: $msg"
jpayne@68: 		} on ok {} {
jpayne@68: 		    set procdDirs($dir) 1
jpayne@68: 		}
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	set use_path [lrange $use_path 0 end-1]
jpayne@68: 
jpayne@68: 	# Check whether any of the index scripts we [source]d above set a new
jpayne@68: 	# value for $::auto_path.  If so, then find any new directories on the
jpayne@68: 	# $::auto_path, and lappend them to the $use_path we are working from.
jpayne@68: 	# This gives index scripts the (arguably unwise) power to expand the
jpayne@68: 	# index script search path while the search is in progress.
jpayne@68: 	set index 0
jpayne@68: 	if {[llength $old_path] == [llength $auto_path]} {
jpayne@68: 	    foreach dir $auto_path old $old_path {
jpayne@68: 		if {$dir ne $old} {
jpayne@68: 		    # This entry in $::auto_path has changed.
jpayne@68: 		    break
jpayne@68: 		}
jpayne@68: 		incr index
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	# $index now points to the first element of $auto_path that has
jpayne@68: 	# changed, or the beginning if $auto_path has changed length Scan the
jpayne@68: 	# new elements of $auto_path for directories to add to $use_path.
jpayne@68: 	# Don't add directories we've already seen, or ones already on the
jpayne@68: 	# $use_path.
jpayne@68: 	foreach dir [lrange $auto_path $index end] {
jpayne@68: 	    if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
jpayne@68: 		lappend use_path $dir
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	set old_path $auto_path
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: # tcl::MacOSXPkgUnknown --
jpayne@68: # This procedure extends the "package unknown" function for MacOSX.  It scans
jpayne@68: # the Resources/Scripts directories of the immediate children of the auto_path
jpayne@68: # directories for pkgIndex files.
jpayne@68: #
jpayne@68: # Arguments:
jpayne@68: # original -		original [package unknown] procedure
jpayne@68: # name -		Name of desired package.  Not used.
jpayne@68: # version -		Version of desired package.  Not used.
jpayne@68: # exact -		Either "-exact" or omitted.  Not used.
jpayne@68: 
jpayne@68: proc tcl::MacOSXPkgUnknown {original name args} {
jpayne@68:     #  First do the cross-platform default search
jpayne@68:     uplevel 1 $original [linsert $args 0 $name]
jpayne@68: 
jpayne@68:     # Now do MacOSX specific searching
jpayne@68:     global auto_path
jpayne@68: 
jpayne@68:     if {![info exists auto_path]} {
jpayne@68: 	return
jpayne@68:     }
jpayne@68:     # Cache the auto_path, because it may change while we run through the
jpayne@68:     # first set of pkgIndex.tcl files
jpayne@68:     set old_path [set use_path $auto_path]
jpayne@68:     while {[llength $use_path]} {
jpayne@68: 	set dir [lindex $use_path end]
jpayne@68: 
jpayne@68: 	# Make sure we only scan each directory one time.
jpayne@68: 	if {[info exists tclSeenPath($dir)]} {
jpayne@68: 	    set use_path [lrange $use_path 0 end-1]
jpayne@68: 	    continue
jpayne@68: 	}
jpayne@68: 	set tclSeenPath($dir) 1
jpayne@68: 
jpayne@68: 	# get the pkgIndex files out of the subdirectories
jpayne@68: 	# Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl.
jpayne@68: 	foreach file [glob -directory $dir -join -nocomplain \
jpayne@68: 		* Resources Scripts pkgIndex.tcl] {
jpayne@68: 	    set dir [file dirname $file]
jpayne@68: 	    if {![info exists procdDirs($dir)]} {
jpayne@68: 		try {
jpayne@68: 		    source $file
jpayne@68: 		} trap {POSIX EACCES} {} {
jpayne@68: 		    # $file was not readable; silently ignore
jpayne@68: 		    continue
jpayne@68: 		} on error msg {
jpayne@68: 		    tclLog "error reading package index file $file: $msg"
jpayne@68: 		} on ok {} {
jpayne@68: 		    set procdDirs($dir) 1
jpayne@68: 		}
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	set use_path [lrange $use_path 0 end-1]
jpayne@68: 
jpayne@68: 	# Check whether any of the index scripts we [source]d above set a new
jpayne@68: 	# value for $::auto_path.  If so, then find any new directories on the
jpayne@68: 	# $::auto_path, and lappend them to the $use_path we are working from.
jpayne@68: 	# This gives index scripts the (arguably unwise) power to expand the
jpayne@68: 	# index script search path while the search is in progress.
jpayne@68: 	set index 0
jpayne@68: 	if {[llength $old_path] == [llength $auto_path]} {
jpayne@68: 	    foreach dir $auto_path old $old_path {
jpayne@68: 		if {$dir ne $old} {
jpayne@68: 		    # This entry in $::auto_path has changed.
jpayne@68: 		    break
jpayne@68: 		}
jpayne@68: 		incr index
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 
jpayne@68: 	# $index now points to the first element of $auto_path that has
jpayne@68: 	# changed, or the beginning if $auto_path has changed length Scan the
jpayne@68: 	# new elements of $auto_path for directories to add to $use_path.
jpayne@68: 	# Don't add directories we've already seen, or ones already on the
jpayne@68: 	# $use_path.
jpayne@68: 	foreach dir [lrange $auto_path $index end] {
jpayne@68: 	    if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
jpayne@68: 		lappend use_path $dir
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	set old_path $auto_path
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: # ::tcl::Pkg::Create --
jpayne@68: #
jpayne@68: #	Given a package specification generate a "package ifneeded" statement
jpayne@68: #	for the package, suitable for inclusion in a pkgIndex.tcl file.
jpayne@68: #
jpayne@68: # Arguments:
jpayne@68: #	args		arguments used by the Create function:
jpayne@68: #			-name		packageName
jpayne@68: #			-version	packageVersion
jpayne@68: #			-load		{filename ?{procs}?}
jpayne@68: #			...
jpayne@68: #			-source		{filename ?{procs}?}
jpayne@68: #			...
jpayne@68: #
jpayne@68: #			Any number of -load and -source parameters may be
jpayne@68: #			specified, so long as there is at least one -load or
jpayne@68: #			-source parameter.  If the procs component of a module
jpayne@68: #			specifier is left off, that module will be set up for
jpayne@68: #			direct loading; otherwise, it will be set up for lazy
jpayne@68: #			loading.  If both -source and -load are specified, the
jpayne@68: #			-load'ed files will be loaded first, followed by the
jpayne@68: #			-source'd files.
jpayne@68: #
jpayne@68: # Results:
jpayne@68: #	An appropriate "package ifneeded" statement for the package.
jpayne@68: 
jpayne@68: proc ::tcl::Pkg::Create {args} {
jpayne@68:     append err(usage) "[lindex [info level 0] 0] "
jpayne@68:     append err(usage) "-name packageName -version packageVersion"
jpayne@68:     append err(usage) "?-load {filename ?{procs}?}? ... "
jpayne@68:     append err(usage) "?-source {filename ?{procs}?}? ..."
jpayne@68: 
jpayne@68:     set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
jpayne@68:     set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
jpayne@68:     set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
jpayne@68:     set err(noLoadOrSource) "at least one of -load and -source must be given"
jpayne@68: 
jpayne@68:     # process arguments
jpayne@68:     set len [llength $args]
jpayne@68:     if {$len < 6} {
jpayne@68: 	error $err(wrongNumArgs)
jpayne@68:     }
jpayne@68: 
jpayne@68:     # Initialize parameters
jpayne@68:     array set opts {-name {} -version {} -source {} -load {}}
jpayne@68: 
jpayne@68:     # process parameters
jpayne@68:     for {set i 0} {$i < $len} {incr i} {
jpayne@68: 	set flag [lindex $args $i]
jpayne@68: 	incr i
jpayne@68: 	switch -glob -- $flag {
jpayne@68: 	    "-name"		-
jpayne@68: 	    "-version"		{
jpayne@68: 		if {$i >= $len} {
jpayne@68: 		    error [format $err(valueMissing) $flag]
jpayne@68: 		}
jpayne@68: 		set opts($flag) [lindex $args $i]
jpayne@68: 	    }
jpayne@68: 	    "-source"		-
jpayne@68: 	    "-load"		{
jpayne@68: 		if {$i >= $len} {
jpayne@68: 		    error [format $err(valueMissing) $flag]
jpayne@68: 		}
jpayne@68: 		lappend opts($flag) [lindex $args $i]
jpayne@68: 	    }
jpayne@68: 	    default {
jpayne@68: 		error [format $err(unknownOpt) [lindex $args $i]]
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68:     }
jpayne@68: 
jpayne@68:     # Validate the parameters
jpayne@68:     if {![llength $opts(-name)]} {
jpayne@68: 	error [format $err(valueMissing) "-name"]
jpayne@68:     }
jpayne@68:     if {![llength $opts(-version)]} {
jpayne@68: 	error [format $err(valueMissing) "-version"]
jpayne@68:     }
jpayne@68: 
jpayne@68:     if {!([llength $opts(-source)] || [llength $opts(-load)])} {
jpayne@68: 	error $err(noLoadOrSource)
jpayne@68:     }
jpayne@68: 
jpayne@68:     # OK, now everything is good.  Generate the package ifneeded statment.
jpayne@68:     set cmdline "package ifneeded $opts(-name) $opts(-version) "
jpayne@68: 
jpayne@68:     set cmdList {}
jpayne@68:     set lazyFileList {}
jpayne@68: 
jpayne@68:     # Handle -load and -source specs
jpayne@68:     foreach key {load source} {
jpayne@68: 	foreach filespec $opts(-$key) {
jpayne@68: 	    lassign $filespec filename proclist
jpayne@68: 
jpayne@68: 	    if { [llength $proclist] == 0 } {
jpayne@68: 		set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
jpayne@68: 		lappend cmdList $cmd
jpayne@68: 	    } else {
jpayne@68: 		lappend lazyFileList [list $filename $key $proclist]
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68:     }
jpayne@68: 
jpayne@68:     if {[llength $lazyFileList]} {
jpayne@68: 	lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
jpayne@68: 		$opts(-version) [list $lazyFileList]\]"
jpayne@68:     }
jpayne@68:     append cmdline [join $cmdList "\\n"]
jpayne@68:     return $cmdline
jpayne@68: }
jpayne@68: 
jpayne@68: interp alias {} ::pkg::create {} ::tcl::Pkg::Create