os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/package.tcl
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/package.tcl Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,828 @@
1.4 +# package.tcl --
1.5 +#
1.6 +# utility procs formerly in init.tcl which can be loaded on demand
1.7 +# for package management.
1.8 +#
1.9 +# RCS: @(#) $Id: package.tcl,v 1.23.2.4 2006/09/22 01:26:24 andreas_kupries Exp $
1.10 +#
1.11 +# Copyright (c) 1991-1993 The Regents of the University of California.
1.12 +# Copyright (c) 1994-1998 Sun Microsystems, Inc.
1.13 +#
1.14 +# See the file "license.terms" for information on usage and redistribution
1.15 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 +#
1.17 +
1.18 +# Create the package namespace
1.19 +namespace eval ::pkg {
1.20 +}
1.21 +
1.22 +# pkg_compareExtension --
1.23 +#
1.24 +# Used internally by pkg_mkIndex to compare the extension of a file to
1.25 +# a given extension. On Windows, it uses a case-insensitive comparison
1.26 +# because the file system can be file insensitive.
1.27 +#
1.28 +# Arguments:
1.29 +# fileName name of a file whose extension is compared
1.30 +# ext (optional) The extension to compare against; you must
1.31 +# provide the starting dot.
1.32 +# Defaults to [info sharedlibextension]
1.33 +#
1.34 +# Results:
1.35 +# Returns 1 if the extension matches, 0 otherwise
1.36 +
1.37 +proc pkg_compareExtension { fileName {ext {}} } {
1.38 + global tcl_platform
1.39 + if {$ext eq ""} {set ext [info sharedlibextension]}
1.40 + if {$tcl_platform(platform) eq "windows"} {
1.41 + return [string equal -nocase [file extension $fileName] $ext]
1.42 + } else {
1.43 + # Some unices add trailing numbers after the .so, so
1.44 + # we could have something like '.so.1.2'.
1.45 + set root $fileName
1.46 + while {1} {
1.47 + set currExt [file extension $root]
1.48 + if {$currExt eq $ext} {
1.49 + return 1
1.50 + }
1.51 +
1.52 + # The current extension does not match; if it is not a numeric
1.53 + # value, quit, as we are only looking to ignore version number
1.54 + # extensions. Otherwise we might return 1 in this case:
1.55 + # pkg_compareExtension foo.so.bar .so
1.56 + # which should not match.
1.57 +
1.58 + if { ![string is integer -strict [string range $currExt 1 end]] } {
1.59 + return 0
1.60 + }
1.61 + set root [file rootname $root]
1.62 + }
1.63 + }
1.64 +}
1.65 +
1.66 +# pkg_mkIndex --
1.67 +# This procedure creates a package index in a given directory. The
1.68 +# package index consists of a "pkgIndex.tcl" file whose contents are
1.69 +# a Tcl script that sets up package information with "package require"
1.70 +# commands. The commands describe all of the packages defined by the
1.71 +# files given as arguments.
1.72 +#
1.73 +# Arguments:
1.74 +# -direct (optional) If this flag is present, the generated
1.75 +# code in pkgMkIndex.tcl will cause the package to be
1.76 +# loaded when "package require" is executed, rather
1.77 +# than lazily when the first reference to an exported
1.78 +# procedure in the package is made.
1.79 +# -verbose (optional) Verbose output; the name of each file that
1.80 +# was successfully rocessed is printed out. Additionally,
1.81 +# if processing of a file failed a message is printed.
1.82 +# -load pat (optional) Preload any packages whose names match
1.83 +# the pattern. Used to handle DLLs that depend on
1.84 +# other packages during their Init procedure.
1.85 +# dir - Name of the directory in which to create the index.
1.86 +# args - Any number of additional arguments, each giving
1.87 +# a glob pattern that matches the names of one or
1.88 +# more shared libraries or Tcl script files in
1.89 +# dir.
1.90 +
1.91 +proc pkg_mkIndex {args} {
1.92 + global errorCode errorInfo
1.93 + set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
1.94 +
1.95 + set argCount [llength $args]
1.96 + if {$argCount < 1} {
1.97 + return -code error "wrong # args: should be\n$usage"
1.98 + }
1.99 +
1.100 + set more ""
1.101 + set direct 1
1.102 + set doVerbose 0
1.103 + set loadPat ""
1.104 + for {set idx 0} {$idx < $argCount} {incr idx} {
1.105 + set flag [lindex $args $idx]
1.106 + switch -glob -- $flag {
1.107 + -- {
1.108 + # done with the flags
1.109 + incr idx
1.110 + break
1.111 + }
1.112 + -verbose {
1.113 + set doVerbose 1
1.114 + }
1.115 + -lazy {
1.116 + set direct 0
1.117 + append more " -lazy"
1.118 + }
1.119 + -direct {
1.120 + append more " -direct"
1.121 + }
1.122 + -load {
1.123 + incr idx
1.124 + set loadPat [lindex $args $idx]
1.125 + append more " -load $loadPat"
1.126 + }
1.127 + -* {
1.128 + return -code error "unknown flag $flag: should be\n$usage"
1.129 + }
1.130 + default {
1.131 + # done with the flags
1.132 + break
1.133 + }
1.134 + }
1.135 + }
1.136 +
1.137 + set dir [lindex $args $idx]
1.138 + set patternList [lrange $args [expr {$idx + 1}] end]
1.139 + if {[llength $patternList] == 0} {
1.140 + set patternList [list "*.tcl" "*[info sharedlibextension]"]
1.141 + }
1.142 +
1.143 + set oldDir [pwd]
1.144 + cd $dir
1.145 +
1.146 + if {[catch {eval [linsert $patternList 0 glob --]} fileList]} {
1.147 + global errorCode errorInfo
1.148 + cd $oldDir
1.149 + return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
1.150 + }
1.151 + foreach file $fileList {
1.152 + # For each file, figure out what commands and packages it provides.
1.153 + # To do this, create a child interpreter, load the file into the
1.154 + # interpreter, and get a list of the new commands and packages
1.155 + # that are defined.
1.156 +
1.157 + if {$file eq "pkgIndex.tcl"} {
1.158 + continue
1.159 + }
1.160 +
1.161 + # Changed back to the original directory before initializing the
1.162 + # slave in case TCL_LIBRARY is a relative path (e.g. in the test
1.163 + # suite).
1.164 +
1.165 + cd $oldDir
1.166 + set c [interp create]
1.167 +
1.168 + # Load into the child any packages currently loaded in the parent
1.169 + # interpreter that match the -load pattern.
1.170 +
1.171 + if {$loadPat ne ""} {
1.172 + if {$doVerbose} {
1.173 + tclLog "currently loaded packages: '[info loaded]'"
1.174 + tclLog "trying to load all packages matching $loadPat"
1.175 + }
1.176 + if {![llength [info loaded]]} {
1.177 + tclLog "warning: no packages are currently loaded, nothing"
1.178 + tclLog "can possibly match '$loadPat'"
1.179 + }
1.180 + }
1.181 + foreach pkg [info loaded] {
1.182 + if {! [string match -nocase $loadPat [lindex $pkg 1]]} {
1.183 + continue
1.184 + }
1.185 + if {$doVerbose} {
1.186 + tclLog "package [lindex $pkg 1] matches '$loadPat'"
1.187 + }
1.188 + if {[catch {
1.189 + load [lindex $pkg 0] [lindex $pkg 1] $c
1.190 + } err]} {
1.191 + if {$doVerbose} {
1.192 + tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
1.193 + }
1.194 + } elseif {$doVerbose} {
1.195 + tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
1.196 + }
1.197 + if {[lindex $pkg 1] eq "Tk"} {
1.198 + # Withdraw . if Tk was loaded, to avoid showing a window.
1.199 + $c eval [list wm withdraw .]
1.200 + }
1.201 + }
1.202 + cd $dir
1.203 +
1.204 + $c eval {
1.205 + # Stub out the package command so packages can
1.206 + # require other packages.
1.207 +
1.208 + rename package __package_orig
1.209 + proc package {what args} {
1.210 + switch -- $what {
1.211 + require { return ; # ignore transitive requires }
1.212 + default { uplevel 1 [linsert $args 0 __package_orig $what] }
1.213 + }
1.214 + }
1.215 + proc tclPkgUnknown args {}
1.216 + package unknown tclPkgUnknown
1.217 +
1.218 + # Stub out the unknown command so package can call
1.219 + # into each other during their initialilzation.
1.220 +
1.221 + proc unknown {args} {}
1.222 +
1.223 + # Stub out the auto_import mechanism
1.224 +
1.225 + proc auto_import {args} {}
1.226 +
1.227 + # reserve the ::tcl namespace for support procs
1.228 + # and temporary variables. This might make it awkward
1.229 + # to generate a pkgIndex.tcl file for the ::tcl namespace.
1.230 +
1.231 + namespace eval ::tcl {
1.232 + variable file ;# Current file being processed
1.233 + variable direct ;# -direct flag value
1.234 + variable x ;# Loop variable
1.235 + variable debug ;# For debugging
1.236 + variable type ;# "load" or "source", for -direct
1.237 + variable namespaces ;# Existing namespaces (e.g., ::tcl)
1.238 + variable packages ;# Existing packages (e.g., Tcl)
1.239 + variable origCmds ;# Existing commands
1.240 + variable newCmds ;# Newly created commands
1.241 + variable newPkgs {} ;# Newly created packages
1.242 + }
1.243 + }
1.244 +
1.245 + $c eval [list set ::tcl::file $file]
1.246 + $c eval [list set ::tcl::direct $direct]
1.247 +
1.248 + # Download needed procedures into the slave because we've
1.249 + # just deleted the unknown procedure. This doesn't handle
1.250 + # procedures with default arguments.
1.251 +
1.252 + foreach p {pkg_compareExtension} {
1.253 + $c eval [list proc $p [info args $p] [info body $p]]
1.254 + }
1.255 +
1.256 + if {[catch {
1.257 + $c eval {
1.258 + set ::tcl::debug "loading or sourcing"
1.259 +
1.260 + # we need to track command defined by each package even in
1.261 + # the -direct case, because they are needed internally by
1.262 + # the "partial pkgIndex.tcl" step above.
1.263 +
1.264 + proc ::tcl::GetAllNamespaces {{root ::}} {
1.265 + set list $root
1.266 + foreach ns [namespace children $root] {
1.267 + eval [linsert [::tcl::GetAllNamespaces $ns] 0 \
1.268 + lappend list]
1.269 + }
1.270 + return $list
1.271 + }
1.272 +
1.273 + # init the list of existing namespaces, packages, commands
1.274 +
1.275 + foreach ::tcl::x [::tcl::GetAllNamespaces] {
1.276 + set ::tcl::namespaces($::tcl::x) 1
1.277 + }
1.278 + foreach ::tcl::x [package names] {
1.279 + if {[package provide $::tcl::x] ne ""} {
1.280 + set ::tcl::packages($::tcl::x) 1
1.281 + }
1.282 + }
1.283 + set ::tcl::origCmds [info commands]
1.284 +
1.285 + # Try to load the file if it has the shared library
1.286 + # extension, otherwise source it. It's important not to
1.287 + # try to load files that aren't shared libraries, because
1.288 + # on some systems (like SunOS) the loader will abort the
1.289 + # whole application when it gets an error.
1.290 +
1.291 + if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
1.292 + # The "file join ." command below is necessary.
1.293 + # Without it, if the file name has no \'s and we're
1.294 + # on UNIX, the load command will invoke the
1.295 + # LD_LIBRARY_PATH search mechanism, which could cause
1.296 + # the wrong file to be used.
1.297 +
1.298 + set ::tcl::debug loading
1.299 + load [file join . $::tcl::file]
1.300 + set ::tcl::type load
1.301 + } else {
1.302 + set ::tcl::debug sourcing
1.303 + source $::tcl::file
1.304 + set ::tcl::type source
1.305 + }
1.306 +
1.307 + # As a performance optimization, if we are creating
1.308 + # direct load packages, don't bother figuring out the
1.309 + # set of commands created by the new packages. We
1.310 + # only need that list for setting up the autoloading
1.311 + # used in the non-direct case.
1.312 + if { !$::tcl::direct } {
1.313 + # See what new namespaces appeared, and import commands
1.314 + # from them. Only exported commands go into the index.
1.315 +
1.316 + foreach ::tcl::x [::tcl::GetAllNamespaces] {
1.317 + if {! [info exists ::tcl::namespaces($::tcl::x)]} {
1.318 + namespace import -force ${::tcl::x}::*
1.319 + }
1.320 +
1.321 + # Figure out what commands appeared
1.322 +
1.323 + foreach ::tcl::x [info commands] {
1.324 + set ::tcl::newCmds($::tcl::x) 1
1.325 + }
1.326 + foreach ::tcl::x $::tcl::origCmds {
1.327 + unset -nocomplain ::tcl::newCmds($::tcl::x)
1.328 + }
1.329 + foreach ::tcl::x [array names ::tcl::newCmds] {
1.330 + # determine which namespace a command comes from
1.331 +
1.332 + set ::tcl::abs [namespace origin $::tcl::x]
1.333 +
1.334 + # special case so that global names have no leading
1.335 + # ::, this is required by the unknown command
1.336 +
1.337 + set ::tcl::abs \
1.338 + [lindex [auto_qualify $::tcl::abs ::] 0]
1.339 +
1.340 + if {$::tcl::x ne $::tcl::abs} {
1.341 + # Name changed during qualification
1.342 +
1.343 + set ::tcl::newCmds($::tcl::abs) 1
1.344 + unset ::tcl::newCmds($::tcl::x)
1.345 + }
1.346 + }
1.347 + }
1.348 + }
1.349 +
1.350 + # Look through the packages that appeared, and if there is
1.351 + # a version provided, then record it
1.352 +
1.353 + foreach ::tcl::x [package names] {
1.354 + if {[package provide $::tcl::x] ne ""
1.355 + && ![info exists ::tcl::packages($::tcl::x)]} {
1.356 + lappend ::tcl::newPkgs \
1.357 + [list $::tcl::x [package provide $::tcl::x]]
1.358 + }
1.359 + }
1.360 + }
1.361 + } msg] == 1} {
1.362 + set what [$c eval set ::tcl::debug]
1.363 + if {$doVerbose} {
1.364 + tclLog "warning: error while $what $file: $msg"
1.365 + }
1.366 + } else {
1.367 + set what [$c eval set ::tcl::debug]
1.368 + if {$doVerbose} {
1.369 + tclLog "successful $what of $file"
1.370 + }
1.371 + set type [$c eval set ::tcl::type]
1.372 + set cmds [lsort [$c eval array names ::tcl::newCmds]]
1.373 + set pkgs [$c eval set ::tcl::newPkgs]
1.374 + if {$doVerbose} {
1.375 + if { !$direct } {
1.376 + tclLog "commands provided were $cmds"
1.377 + }
1.378 + tclLog "packages provided were $pkgs"
1.379 + }
1.380 + if {[llength $pkgs] > 1} {
1.381 + tclLog "warning: \"$file\" provides more than one package ($pkgs)"
1.382 + }
1.383 + foreach pkg $pkgs {
1.384 + # cmds is empty/not used in the direct case
1.385 + lappend files($pkg) [list $file $type $cmds]
1.386 + }
1.387 +
1.388 + if {$doVerbose} {
1.389 + tclLog "processed $file"
1.390 + }
1.391 + }
1.392 + interp delete $c
1.393 + }
1.394 +
1.395 + append index "# Tcl package index file, version 1.1\n"
1.396 + append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
1.397 + append index "# and sourced either when an application starts up or\n"
1.398 + append index "# by a \"package unknown\" script. It invokes the\n"
1.399 + append index "# \"package ifneeded\" command to set up package-related\n"
1.400 + append index "# information so that packages will be loaded automatically\n"
1.401 + append index "# in response to \"package require\" commands. When this\n"
1.402 + append index "# script is sourced, the variable \$dir must contain the\n"
1.403 + append index "# full path name of this file's directory.\n"
1.404 +
1.405 + foreach pkg [lsort [array names files]] {
1.406 + set cmd {}
1.407 + foreach {name version} $pkg {
1.408 + break
1.409 + }
1.410 + lappend cmd ::pkg::create -name $name -version $version
1.411 + foreach spec $files($pkg) {
1.412 + foreach {file type procs} $spec {
1.413 + if { $direct } {
1.414 + set procs {}
1.415 + }
1.416 + lappend cmd "-$type" [list $file $procs]
1.417 + }
1.418 + }
1.419 + append index "\n[eval $cmd]"
1.420 + }
1.421 +
1.422 + set f [open pkgIndex.tcl w]
1.423 + puts $f $index
1.424 + close $f
1.425 + cd $oldDir
1.426 +}
1.427 +
1.428 +# tclPkgSetup --
1.429 +# This is a utility procedure use by pkgIndex.tcl files. It is invoked
1.430 +# as part of a "package ifneeded" script. It calls "package provide"
1.431 +# to indicate that a package is available, then sets entries in the
1.432 +# auto_index array so that the package's files will be auto-loaded when
1.433 +# the commands are used.
1.434 +#
1.435 +# Arguments:
1.436 +# dir - Directory containing all the files for this package.
1.437 +# pkg - Name of the package (no version number).
1.438 +# version - Version number for the package, such as 2.1.3.
1.439 +# files - List of files that constitute the package. Each
1.440 +# element is a sub-list with three elements. The first
1.441 +# is the name of a file relative to $dir, the second is
1.442 +# "load" or "source", indicating whether the file is a
1.443 +# loadable binary or a script to source, and the third
1.444 +# is a list of commands defined by this file.
1.445 +
1.446 +proc tclPkgSetup {dir pkg version files} {
1.447 + global auto_index
1.448 +
1.449 + package provide $pkg $version
1.450 + foreach fileInfo $files {
1.451 + set f [lindex $fileInfo 0]
1.452 + set type [lindex $fileInfo 1]
1.453 + foreach cmd [lindex $fileInfo 2] {
1.454 + if {$type eq "load"} {
1.455 + set auto_index($cmd) [list load [file join $dir $f] $pkg]
1.456 + } else {
1.457 + set auto_index($cmd) [list source [file join $dir $f]]
1.458 + }
1.459 + }
1.460 + }
1.461 +}
1.462 +
1.463 +# tclPkgUnknown --
1.464 +# This procedure provides the default for the "package unknown" function.
1.465 +# It is invoked when a package that's needed can't be found. It scans
1.466 +# the auto_path directories and their immediate children looking for
1.467 +# pkgIndex.tcl files and sources any such files that are found to setup
1.468 +# the package database. (On the Macintosh we also search for pkgIndex
1.469 +# TEXT resources in all files.) As it searches, it will recognize changes
1.470 +# to the auto_path and scan any new directories.
1.471 +#
1.472 +# Arguments:
1.473 +# name - Name of desired package. Not used.
1.474 +# version - Version of desired package. Not used.
1.475 +# exact - Either "-exact" or omitted. Not used.
1.476 +
1.477 +
1.478 +proc tclPkgUnknown [expr {
1.479 + [info exists tcl_platform(tip,268)]
1.480 + ? "name args"
1.481 + : "name version {exact {}}"
1.482 + }] {
1.483 + global auto_path env
1.484 +
1.485 + if {![info exists auto_path]} {
1.486 + return
1.487 + }
1.488 + # Cache the auto_path, because it may change while we run through
1.489 + # the first set of pkgIndex.tcl files
1.490 + set old_path [set use_path $auto_path]
1.491 + while {[llength $use_path]} {
1.492 + set dir [lindex $use_path end]
1.493 +
1.494 + # Make sure we only scan each directory one time.
1.495 + if {[info exists tclSeenPath($dir)]} {
1.496 + set use_path [lrange $use_path 0 end-1]
1.497 + continue
1.498 + }
1.499 + set tclSeenPath($dir) 1
1.500 +
1.501 + # we can't use glob in safe interps, so enclose the following
1.502 + # in a catch statement, where we get the pkgIndex files out
1.503 + # of the subdirectories
1.504 + catch {
1.505 + foreach file [glob -directory $dir -join -nocomplain \
1.506 + * pkgIndex.tcl] {
1.507 + set dir [file dirname $file]
1.508 + if {![info exists procdDirs($dir)] && [file readable $file]} {
1.509 + if {[catch {source $file} msg]} {
1.510 + tclLog "error reading package index file $file: $msg"
1.511 + } else {
1.512 + set procdDirs($dir) 1
1.513 + }
1.514 + }
1.515 + }
1.516 + }
1.517 + set dir [lindex $use_path end]
1.518 + if {![info exists procdDirs($dir)]} {
1.519 + set file [file join $dir pkgIndex.tcl]
1.520 + # safe interps usually don't have "file readable",
1.521 + # nor stderr channel
1.522 + if {([interp issafe] || [file readable $file])} {
1.523 + if {[catch {source $file} msg] && ![interp issafe]} {
1.524 + tclLog "error reading package index file $file: $msg"
1.525 + } else {
1.526 + set procdDirs($dir) 1
1.527 + }
1.528 + }
1.529 + }
1.530 +
1.531 + set use_path [lrange $use_path 0 end-1]
1.532 +
1.533 + # Check whether any of the index scripts we [source]d above
1.534 + # set a new value for $::auto_path. If so, then find any
1.535 + # new directories on the $::auto_path, and lappend them to
1.536 + # the $use_path we are working from. This gives index scripts
1.537 + # the (arguably unwise) power to expand the index script search
1.538 + # path while the search is in progress.
1.539 + set index 0
1.540 + if {[llength $old_path] == [llength $auto_path]} {
1.541 + foreach dir $auto_path old $old_path {
1.542 + if {$dir ne $old} {
1.543 + # This entry in $::auto_path has changed.
1.544 + break
1.545 + }
1.546 + incr index
1.547 + }
1.548 + }
1.549 +
1.550 + # $index now points to the first element of $auto_path that
1.551 + # has changed, or the beginning if $auto_path has changed length
1.552 + # Scan the new elements of $auto_path for directories to add to
1.553 + # $use_path. Don't add directories we've already seen, or ones
1.554 + # already on the $use_path.
1.555 + foreach dir [lrange $auto_path $index end] {
1.556 + if {![info exists tclSeenPath($dir)]
1.557 + && ([lsearch -exact $use_path $dir] == -1) } {
1.558 + lappend use_path $dir
1.559 + }
1.560 + }
1.561 + set old_path $auto_path
1.562 + }
1.563 +}
1.564 +
1.565 +# tcl::MacOSXPkgUnknown --
1.566 +# This procedure extends the "package unknown" function for MacOSX.
1.567 +# It scans the Resources/Scripts directories of the immediate children
1.568 +# of the auto_path directories for pkgIndex files.
1.569 +# Only installed in interps that are not safe so we don't check
1.570 +# for [interp issafe] as in tclPkgUnknown.
1.571 +#
1.572 +# Arguments:
1.573 +# original - original [package unknown] procedure
1.574 +# name - Name of desired package. Not used.
1.575 +#ifndef TCL_TIP268
1.576 +# version - Version of desired package. Not used.
1.577 +# exact - Either "-exact" or omitted. Not used.
1.578 +#else
1.579 +# args - List of requirements. Not used.
1.580 +#endif
1.581 +
1.582 +if {[info exists tcl_platform(tip,268)]} {
1.583 + proc tcl::MacOSXPkgUnknown {original name args} {
1.584 + # First do the cross-platform default search
1.585 + uplevel 1 $original [linsert $args 0 $name]
1.586 +
1.587 + # Now do MacOSX specific searching
1.588 + global auto_path
1.589 +
1.590 + if {![info exists auto_path]} {
1.591 + return
1.592 + }
1.593 + # Cache the auto_path, because it may change while we run through
1.594 + # the first set of pkgIndex.tcl files
1.595 + set old_path [set use_path $auto_path]
1.596 + while {[llength $use_path]} {
1.597 + set dir [lindex $use_path end]
1.598 + # get the pkgIndex files out of the subdirectories
1.599 + foreach file [glob -directory $dir -join -nocomplain \
1.600 + * Resources Scripts pkgIndex.tcl] {
1.601 + set dir [file dirname $file]
1.602 + if {[file readable $file] && ![info exists procdDirs($dir)]} {
1.603 + if {[catch {source $file} msg]} {
1.604 + tclLog "error reading package index file $file: $msg"
1.605 + } else {
1.606 + set procdDirs($dir) 1
1.607 + }
1.608 + }
1.609 + }
1.610 + set use_path [lrange $use_path 0 end-1]
1.611 + if {$old_path ne $auto_path} {
1.612 + foreach dir $auto_path {
1.613 + lappend use_path $dir
1.614 + }
1.615 + set old_path $auto_path
1.616 + }
1.617 + }
1.618 + }
1.619 +} else {
1.620 + proc tcl::MacOSXPkgUnknown {original name version {exact {}}} {
1.621 +
1.622 + # First do the cross-platform default search
1.623 + uplevel 1 $original [list $name $version $exact]
1.624 +
1.625 + # Now do MacOSX specific searching
1.626 + global auto_path
1.627 +
1.628 + if {![info exists auto_path]} {
1.629 + return
1.630 + }
1.631 + # Cache the auto_path, because it may change while we run through
1.632 + # the first set of pkgIndex.tcl files
1.633 + set old_path [set use_path $auto_path]
1.634 + while {[llength $use_path]} {
1.635 + set dir [lindex $use_path end]
1.636 + # get the pkgIndex files out of the subdirectories
1.637 + foreach file [glob -directory $dir -join -nocomplain \
1.638 + * Resources Scripts pkgIndex.tcl] {
1.639 + set dir [file dirname $file]
1.640 + if {[file readable $file] && ![info exists procdDirs($dir)]} {
1.641 + if {[catch {source $file} msg]} {
1.642 + tclLog "error reading package index file $file: $msg"
1.643 + } else {
1.644 + set procdDirs($dir) 1
1.645 + }
1.646 + }
1.647 + }
1.648 + set use_path [lrange $use_path 0 end-1]
1.649 + if {$old_path ne $auto_path} {
1.650 + foreach dir $auto_path {
1.651 + lappend use_path $dir
1.652 + }
1.653 + set old_path $auto_path
1.654 + }
1.655 + }
1.656 + }
1.657 +}
1.658 +
1.659 +# tcl::MacPkgUnknown --
1.660 +# This procedure extends the "package unknown" function for Mac.
1.661 +# It searches for pkgIndex TEXT resources in all files
1.662 +# Only installed in interps that are not safe so we don't check
1.663 +# for [interp issafe] as in tclPkgUnknown.
1.664 +#
1.665 +# Arguments:
1.666 +# original - original [package unknown] procedure
1.667 +# name - Name of desired package. Not used.
1.668 +# version - Version of desired package. Not used.
1.669 +# exact - Either "-exact" or omitted. Not used.
1.670 +
1.671 +proc tcl::MacPkgUnknown {original name version {exact {}}} {
1.672 +
1.673 + # First do the cross-platform default search
1.674 + uplevel 1 $original [list $name $version $exact]
1.675 +
1.676 + # Now do Mac specific searching
1.677 + global auto_path
1.678 +
1.679 + if {![info exists auto_path]} {
1.680 + return
1.681 + }
1.682 + # Cache the auto_path, because it may change while we run through
1.683 + # the first set of pkgIndex.tcl files
1.684 + set old_path [set use_path $auto_path]
1.685 + while {[llength $use_path]} {
1.686 + # We look for pkgIndex TEXT resources in the resource fork of shared libraries
1.687 + set dir [lindex $use_path end]
1.688 + foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
1.689 + if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
1.690 + set dir $x
1.691 + foreach x [glob -directory $dir -nocomplain *.shlb] {
1.692 + if {[file isfile $x]} {
1.693 + set res [resource open $x]
1.694 + foreach y [resource list TEXT $res] {
1.695 + if {$y eq "pkgIndex"} {source -rsrc pkgIndex}
1.696 + }
1.697 + catch {resource close $res}
1.698 + }
1.699 + }
1.700 + set procdDirs($dir) 1
1.701 + }
1.702 + }
1.703 + set use_path [lrange $use_path 0 end-1]
1.704 + if {$old_path ne $auto_path} {
1.705 + foreach dir $auto_path {
1.706 + lappend use_path $dir
1.707 + }
1.708 + set old_path $auto_path
1.709 + }
1.710 + }
1.711 +}
1.712 +
1.713 +# ::pkg::create --
1.714 +#
1.715 +# Given a package specification generate a "package ifneeded" statement
1.716 +# for the package, suitable for inclusion in a pkgIndex.tcl file.
1.717 +#
1.718 +# Arguments:
1.719 +# args arguments used by the create function:
1.720 +# -name packageName
1.721 +# -version packageVersion
1.722 +# -load {filename ?{procs}?}
1.723 +# ...
1.724 +# -source {filename ?{procs}?}
1.725 +# ...
1.726 +#
1.727 +# Any number of -load and -source parameters may be
1.728 +# specified, so long as there is at least one -load or
1.729 +# -source parameter. If the procs component of a
1.730 +# module specifier is left off, that module will be
1.731 +# set up for direct loading; otherwise, it will be
1.732 +# set up for lazy loading. If both -source and -load
1.733 +# are specified, the -load'ed files will be loaded
1.734 +# first, followed by the -source'd files.
1.735 +#
1.736 +# Results:
1.737 +# An appropriate "package ifneeded" statement for the package.
1.738 +
1.739 +proc ::pkg::create {args} {
1.740 + append err(usage) "[lindex [info level 0] 0] "
1.741 + append err(usage) "-name packageName -version packageVersion"
1.742 + append err(usage) "?-load {filename ?{procs}?}? ... "
1.743 + append err(usage) "?-source {filename ?{procs}?}? ..."
1.744 +
1.745 + set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
1.746 + set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
1.747 + set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\""
1.748 + set err(noLoadOrSource) "at least one of -load and -source must be given"
1.749 +
1.750 + # process arguments
1.751 + set len [llength $args]
1.752 + if { $len < 6 } {
1.753 + error $err(wrongNumArgs)
1.754 + }
1.755 +
1.756 + # Initialize parameters
1.757 + set opts(-name) {}
1.758 + set opts(-version) {}
1.759 + set opts(-source) {}
1.760 + set opts(-load) {}
1.761 +
1.762 + # process parameters
1.763 + for {set i 0} {$i < $len} {incr i} {
1.764 + set flag [lindex $args $i]
1.765 + incr i
1.766 + switch -glob -- $flag {
1.767 + "-name" -
1.768 + "-version" {
1.769 + if { $i >= $len } {
1.770 + error [format $err(valueMissing) $flag]
1.771 + }
1.772 + set opts($flag) [lindex $args $i]
1.773 + }
1.774 + "-source" -
1.775 + "-load" {
1.776 + if { $i >= $len } {
1.777 + error [format $err(valueMissing) $flag]
1.778 + }
1.779 + lappend opts($flag) [lindex $args $i]
1.780 + }
1.781 + default {
1.782 + error [format $err(unknownOpt) [lindex $args $i]]
1.783 + }
1.784 + }
1.785 + }
1.786 +
1.787 + # Validate the parameters
1.788 + if { [llength $opts(-name)] == 0 } {
1.789 + error [format $err(valueMissing) "-name"]
1.790 + }
1.791 + if { [llength $opts(-version)] == 0 } {
1.792 + error [format $err(valueMissing) "-version"]
1.793 + }
1.794 +
1.795 + if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
1.796 + error $err(noLoadOrSource)
1.797 + }
1.798 +
1.799 + # OK, now everything is good. Generate the package ifneeded statment.
1.800 + set cmdline "package ifneeded $opts(-name) $opts(-version) "
1.801 +
1.802 + set cmdList {}
1.803 + set lazyFileList {}
1.804 +
1.805 + # Handle -load and -source specs
1.806 + foreach key {load source} {
1.807 + foreach filespec $opts(-$key) {
1.808 + foreach {filename proclist} {{} {}} {
1.809 + break
1.810 + }
1.811 + foreach {filename proclist} $filespec {
1.812 + break
1.813 + }
1.814 +
1.815 + if { [llength $proclist] == 0 } {
1.816 + set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
1.817 + lappend cmdList $cmd
1.818 + } else {
1.819 + lappend lazyFileList [list $filename $key $proclist]
1.820 + }
1.821 + }
1.822 + }
1.823 +
1.824 + if { [llength $lazyFileList] > 0 } {
1.825 + lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
1.826 + $opts(-version) [list $lazyFileList]\]"
1.827 + }
1.828 + append cmdline [join $cmdList "\\n"]
1.829 + return $cmdline
1.830 +}
1.831 +