summaryrefslogtreecommitdiffstats
path: root/library/package.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/package.tcl')
-rw-r--r--library/package.tcl335
1 files changed, 208 insertions, 127 deletions
diff --git a/library/package.tcl b/library/package.tcl
index 4dc1859..3783722 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -3,8 +3,6 @@
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
-# RCS: @(#) $Id: package.tcl,v 1.18 2001/07/21 20:26:42 dgp Exp $
-#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
@@ -12,11 +10,9 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# Create the package namespace
-namespace eval ::pkg {
-}
+namespace eval tcl::Pkg {}
-# pkg_compareExtension --
+# ::tcl::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
@@ -31,10 +27,10 @@ namespace eval ::pkg {
# Results:
# Returns 1 if the extension matches, 0 otherwise
-proc pkg_compareExtension { fileName {ext {}} } {
+proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
global tcl_platform
- if {![string length $ext]} {set ext [info sharedlibextension]}
- if {[string equal $tcl_platform(platform) "windows"]} {
+ if {$ext eq ""} {set ext [info sharedlibextension]}
+ if {$tcl_platform(platform) eq "windows"} {
return [string equal -nocase [file extension $fileName] $ext]
} else {
# Some unices add trailing numbers after the .so, so
@@ -42,14 +38,14 @@ proc pkg_compareExtension { fileName {ext {}} } {
set root $fileName
while {1} {
set currExt [file extension $root]
- if {[string equal $currExt $ext]} {
+ if {$currExt eq $ext} {
return 1
- }
+ }
# 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
+ # tcl::Pkg::CompareExtension foo.so.bar .so
# which should not match.
if { ![string is integer -strict [string range $currExt 1 end]] } {
@@ -86,7 +82,6 @@ proc pkg_compareExtension { fileName {ext {}} } {
# dir.
proc pkg_mkIndex {args} {
- global errorCode errorInfo
set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
set argCount [llength $args]
@@ -137,13 +132,10 @@ proc pkg_mkIndex {args} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
- set oldDir [pwd]
- cd $dir
-
- if {[catch {eval glob $patternList} fileList]} {
- global errorCode errorInfo
- cd $oldDir
- return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
+ if {[catch {
+ glob -directory $dir -tails -types {r f} -- {*}$patternList
+ } fileList o]} {
+ return -options $o $fileList
}
foreach file $fileList {
# For each file, figure out what commands and packages it provides.
@@ -151,21 +143,16 @@ proc pkg_mkIndex {args} {
# interpreter, and get a list of the new commands and packages
# that are defined.
- if {[string equal $file "pkgIndex.tcl"]} {
+ if {$file eq "pkgIndex.tcl"} {
continue
}
- # Changed back to the original directory before initializing the
- # slave in case TCL_LIBRARY is a relative path (e.g. in the test
- # suite).
-
- cd $oldDir
set c [interp create]
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
- if {[string length $loadPat]} {
+ if {$loadPat ne ""} {
if {$doVerbose} {
tclLog "currently loaded packages: '[info loaded]'"
tclLog "trying to load all packages matching $loadPat"
@@ -176,7 +163,7 @@ proc pkg_mkIndex {args} {
}
}
foreach pkg [info loaded] {
- if {! [string match $loadPat [lindex $pkg 1]]} {
+ if {! [string match -nocase $loadPat [lindex $pkg 1]]} {
continue
}
if {$doVerbose} {
@@ -191,12 +178,11 @@ proc pkg_mkIndex {args} {
} elseif {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
- if {[string equal [lindex $pkg 1] "Tk"]} {
+ if {[lindex $pkg 1] eq "Tk"} {
# Withdraw . if Tk was loaded, to avoid showing a window.
$c eval [list wm withdraw .]
}
}
- cd $dir
$c eval {
# Stub out the package command so packages can
@@ -206,7 +192,7 @@ proc pkg_mkIndex {args} {
proc package {what args} {
switch -- $what {
require { return ; # ignore transitive requires }
- default { eval __package_orig {$what} $args }
+ default { __package_orig $what {*}$args }
}
}
proc tclPkgUnknown args {}
@@ -226,6 +212,7 @@ proc pkg_mkIndex {args} {
# to generate a pkgIndex.tcl file for the ::tcl namespace.
namespace eval ::tcl {
+ variable dir ;# Current directory being processed
variable file ;# Current file being processed
variable direct ;# -direct flag value
variable x ;# Loop variable
@@ -239,6 +226,7 @@ proc pkg_mkIndex {args} {
}
}
+ $c eval [list set ::tcl::dir $dir]
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
@@ -246,7 +234,8 @@ proc pkg_mkIndex {args} {
# just deleted the unknown procedure. This doesn't handle
# procedures with default arguments.
- foreach p {pkg_compareExtension} {
+ foreach p {::tcl::Pkg::CompareExtension} {
+ $c eval [list namespace eval [namespace qualifiers $p] {}]
$c eval [list proc $p [info args $p] [info body $p]]
}
@@ -261,7 +250,7 @@ proc pkg_mkIndex {args} {
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
- eval lappend list [::tcl::GetAllNamespaces $ns]
+ lappend list {*}[::tcl::GetAllNamespaces $ns]
}
return $list
}
@@ -272,7 +261,9 @@ proc pkg_mkIndex {args} {
set ::tcl::namespaces($::tcl::x) 1
}
foreach ::tcl::x [package names] {
- set ::tcl::packages($::tcl::x) 1
+ if {[package provide $::tcl::x] ne ""} {
+ set ::tcl::packages($::tcl::x) 1
+ }
}
set ::tcl::origCmds [info commands]
@@ -282,7 +273,7 @@ proc pkg_mkIndex {args} {
# on some systems (like SunOS) the loader will abort the
# whole application when it gets an error.
- if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
+ if {[::tcl::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
@@ -290,50 +281,50 @@ proc pkg_mkIndex {args} {
# the wrong file to be used.
set ::tcl::debug loading
- load [file join . $::tcl::file]
+ load [file join $::tcl::dir $::tcl::file]
set ::tcl::type load
} else {
set ::tcl::debug sourcing
- source $::tcl::file
+ source [file join $::tcl::dir $::tcl::file]
set ::tcl::type source
}
- # 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
+ # 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.
if { !$::tcl::direct } {
# 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)}
+ unset -nocomplain ::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
-
+
set ::tcl::abs \
[lindex [auto_qualify $::tcl::abs ::] 0]
-
- if {[string compare $::tcl::x $::tcl::abs]} {
+
+ if {$::tcl::x ne $::tcl::abs} {
# Name changed during qualification
-
+
set ::tcl::newCmds($::tcl::abs) 1
unset ::tcl::newCmds($::tcl::x)
}
@@ -345,7 +336,7 @@ proc pkg_mkIndex {args} {
# a version provided, then record it
foreach ::tcl::x [package names] {
- if {[string compare [package provide $::tcl::x] ""] \
+ if {[package provide $::tcl::x] ne ""
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
@@ -366,7 +357,9 @@ proc pkg_mkIndex {args} {
set cmds [lsort [$c eval array names ::tcl::newCmds]]
set pkgs [$c eval set ::tcl::newPkgs]
if {$doVerbose} {
- tclLog "commands provided were $cmds"
+ if { !$direct } {
+ tclLog "commands provided were $cmds"
+ }
tclLog "packages provided were $pkgs"
}
if {[llength $pkgs] > 1} {
@@ -380,8 +373,8 @@ proc pkg_mkIndex {args} {
if {$doVerbose} {
tclLog "processed $file"
}
- interp delete $c
}
+ interp delete $c
}
append index "# Tcl package index file, version 1.1\n"
@@ -396,11 +389,9 @@ proc pkg_mkIndex {args} {
foreach pkg [lsort [array names files]] {
set cmd {}
- foreach {name version} $pkg {
- break
- }
- lappend cmd ::pkg::create -name $name -version $version
- foreach spec $files($pkg) {
+ lassign $pkg name version
+ 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 {}
@@ -411,10 +402,9 @@ proc pkg_mkIndex {args} {
append index "\n[eval $cmd]"
}
- set f [open pkgIndex.tcl w]
+ set f [open [file join $dir pkgIndex.tcl] w]
puts $f $index
close $f
- cd $oldDir
}
# tclPkgSetup --
@@ -443,28 +433,11 @@ proc tclPkgSetup {dir pkg version files} {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
- if {[string equal $type "load"]} {
+ 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]]
- }
- }
- }
-}
-
-# tclMacPkgSearch --
-# The procedure is used on the Macintosh to search a given directory for files
-# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the
-# interpreter to setup the package database.
-
-proc tclMacPkgSearch {dir} {
- foreach x [glob -directory $dir -nocomplain *.shlb] {
- if {[file isfile $x]} {
- set res [resource open $x]
- foreach y [resource list TEXT $res] {
- if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex}
}
- catch {resource close $res}
}
}
}
@@ -474,8 +447,7 @@ proc tclMacPkgSearch {dir} {
# 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
+# the package database. As it searches, it will recognize changes
# to the auto_path and scan any new directories.
#
# Arguments:
@@ -483,8 +455,8 @@ proc tclMacPkgSearch {dir} {
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
-proc tclPkgUnknown {name version {exact {}}} {
- global auto_path tcl_platform env
+proc tclPkgUnknown {name args} {
+ global auto_path env
if {![info exists auto_path]} {
return
@@ -494,6 +466,14 @@ proc tclPkgUnknown {name version {exact {}}} {
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
@@ -501,8 +481,15 @@ proc tclPkgUnknown {name version {exact {}}} {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
set dir [file dirname $file]
- if {[file readable $file] && ![info exists procdDirs($dir)]} {
- if {[catch {source $file} msg]} {
+ 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
@@ -511,51 +498,152 @@ proc tclPkgUnknown {name version {exact {}}} {
}
}
set dir [lindex $use_path end]
- set file [file join $dir pkgIndex.tcl]
- # safe interps usually don't have "file readable", nor stderr channel
- if {([interp issafe] || [file readable $file]) && \
- ![info exists procdDirs($dir)]} {
- if {[catch {source $file} msg] && ![interp issafe]} {
- tclLog "error reading package index file $file: $msg"
- } else {
- set procdDirs($dir) 1
+ 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
+ }
}
}
- # On the Macintosh we also look in the resource fork
- # of shared libraries
- # We can't use tclMacPkgSearch in safe interps because it uses glob
- if {(![interp issafe]) && \
- [string equal $tcl_platform(platform) "macintosh"]} {
- set dir [lindex $use_path end]
- if {![info exists procdDirs($dir)]} {
- tclMacPkgSearch $dir
- 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)] && ($dir ni $use_path)} {
+ lappend use_path $dir
}
- foreach x [glob -directory $dir -nocomplain *] {
- if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
- set dir $x
- tclMacPkgSearch $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]
- if {[string compare $old_path $auto_path]} {
- foreach dir $auto_path {
+
+ # 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)] && ($dir ni $use_path)} {
lappend use_path $dir
}
- set old_path $auto_path
}
+ set old_path $auto_path
}
}
-# ::pkg::create --
+# ::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:
+# args arguments used by the Create function:
# -name packageName
# -version packageVersion
# -load {filename ?{procs}?}
@@ -565,17 +653,17 @@ proc tclPkgUnknown {name version {exact {}}} {
#
# 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
+# -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
+# 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 ::pkg::create {args} {
+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}?}? ... "
@@ -591,12 +679,9 @@ proc ::pkg::create {args} {
if { $len < 6 } {
error $err(wrongNumArgs)
}
-
+
# Initialize parameters
- set opts(-name) {}
- set opts(-version) {}
- set opts(-source) {}
- set opts(-load) {}
+ array set opts {-name {} -version {} -source {} -load {}}
# process parameters
for {set i 0} {$i < $len} {incr i} {
@@ -630,27 +715,22 @@ proc ::pkg::create {args} {
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
- }
-
+ lassign $filespec filename proclist
+
if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
@@ -668,3 +748,4 @@ proc ::pkg::create {args} {
return $cmdline
}
+interp alias {} ::pkg::create {} ::tcl::Pkg::Create
generated by cgit v0.12 at 2025-12-25 05:24:34 (GMT)