1} {
tclLog "warning: \"$file\" provides more than one package ($pkgs)"
}
foreach pkg $pkgs {
# cmds is empty/not used in the direct case
lappend files($pkg) [list $file $type $cmds]
}
if {$doVerbose} {
tclLog "processed $file"
}
}
interp delete $c
}
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]] {
set cmd {}
foreach {name version} $pkg {
break
}
lappend cmd ::tcl::Pkg::Create -name $name -version $version
foreach spec [lsort -index 0 $files($pkg)] {
foreach {file type procs} $spec {
if { $direct } {
set procs {}
}
lappend cmd "-$type" [list $file $procs]
}
}
append index "\n[eval $cmd]"
}
set f [open [file join $dir pkgIndex.tcl] w]
puts $f $index
close $f
}
# tclPkgSetup --
# 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
# the commands are used.
#
# Arguments:
# 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} {
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
if {$type eq "load"} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
}
}
}
}
# tclPkgUnknown --
# 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. As it searches, it will recognize changes
# to the auto_path and scan any new directories.
#
# Arguments:
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name args} {
global auto_path env
if {![info exists auto_path]} {
return
}
# 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]
continue
}
set tclSeenPath($dir) 1
# we can't use glob in safe interps, so enclose the following
# in a catch statement, where we get the pkgIndex files out
# of the subdirectories
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
set code [catch {source $file} msg opt]
if {$code == 1 &&
[lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
[lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
# $file was not readable; silently ignore
continue
}
if {$code} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
}
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 exists",
if {([interp issafe] || [file exists $file])} {
set code [catch {source $file} msg opt]
if {$code == 1 &&
[lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
[lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
# $file was not readable; silently ignore
continue
}
if {$code} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
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.
set index 0
if {[llength $old_path] == [llength $auto_path]} {
foreach dir $auto_path old $old_path {
if {$dir ne $old} {
# This entry in $::auto_path has changed.
break
}
incr index
}
}
# $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) } {
lappend use_path $dir
}
}
set old_path $auto_path
}
}
# 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.
#
# Arguments:
# 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 args} {
# First do the cross-platform default search
uplevel 1 $original [linsert $args 0 $name]
# Now do MacOSX specific searching
global auto_path
if {![info exists auto_path]} {
return
}
# 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]
continue
}
set tclSeenPath($dir) 1
# 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 {![info exists procdDirs($dir)]} {
set code [catch {source $file} msg opt]
if {$code == 1 &&
[lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
[lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
# $file was not readable; silently ignore
continue
}
if {$code} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
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.
set index 0
if {[llength $old_path] == [llength $auto_path]} {
foreach dir $auto_path old $old_path {
if {$dir ne $old} {
# This entry in $::auto_path has changed.
break
}
incr index
}
}
# $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) } {
lappend use_path $dir
}
}
set old_path $auto_path
}
}
# ::tcl::Pkg::Create --
#
# Given a package specification generate a "package ifneeded" statement
# for the package, suitable for inclusion in a pkgIndex.tcl file.
#
# Arguments:
# args arguments used by the Create function:
# -name packageName
# -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.
#
# Results:
# An appropriate "package ifneeded" statement for the package.
proc ::tcl::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"
# process arguments
set len [llength $args]
if { $len < 6 } {
error $err(wrongNumArgs)
}
# Initialize parameters
set opts(-name) {}
set opts(-version) {}
set opts(-source) {}
set opts(-load) {}
# process parameters
for {set i 0} {$i < $len} {incr i} {
set flag [lindex $args $i]
incr i
switch -glob -- $flag {
"-name" -
"-version" {
if { $i >= $len } {
error [format $err(valueMissing) $flag]
}
set opts($flag) [lindex $args $i]
}
"-source" -
"-load" {
if { $i >= $len } {
error [format $err(valueMissing) $flag]
}
lappend opts($flag) [lindex $args $i]
}
default {
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) "
set cmdList {}
set lazyFileList {}
# Handle -load and -source specs
foreach key {load source} {
foreach filespec $opts(-$key) {
foreach {filename proclist} {{} {}} {
break
}
foreach {filename proclist} $filespec {
break
}
if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
} else {
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"]
return $cmdline
}
interp alias {} ::pkg::create {} ::tcl::Pkg::Create