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