Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/package.tcl @ 68:5028fdace37b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author jpayne
date Tue, 18 Mar 2025 16:23:26 -0400
parents
children
rev   line source
jpayne@68 1 # package.tcl --
jpayne@68 2 #
jpayne@68 3 # utility procs formerly in init.tcl which can be loaded on demand
jpayne@68 4 # for package management.
jpayne@68 5 #
jpayne@68 6 # Copyright (c) 1991-1993 The Regents of the University of California.
jpayne@68 7 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
jpayne@68 8 #
jpayne@68 9 # See the file "license.terms" for information on usage and redistribution
jpayne@68 10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
jpayne@68 11 #
jpayne@68 12
jpayne@68 13 namespace eval tcl::Pkg {}
jpayne@68 14
jpayne@68 15 # ::tcl::Pkg::CompareExtension --
jpayne@68 16 #
jpayne@68 17 # Used internally by pkg_mkIndex to compare the extension of a file to a given
jpayne@68 18 # extension. On Windows, it uses a case-insensitive comparison because the
jpayne@68 19 # file system can be file insensitive.
jpayne@68 20 #
jpayne@68 21 # Arguments:
jpayne@68 22 # fileName name of a file whose extension is compared
jpayne@68 23 # ext (optional) The extension to compare against; you must
jpayne@68 24 # provide the starting dot.
jpayne@68 25 # Defaults to [info sharedlibextension]
jpayne@68 26 #
jpayne@68 27 # Results:
jpayne@68 28 # Returns 1 if the extension matches, 0 otherwise
jpayne@68 29
jpayne@68 30 proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
jpayne@68 31 global tcl_platform
jpayne@68 32 if {$ext eq ""} {set ext [info sharedlibextension]}
jpayne@68 33 if {$tcl_platform(platform) eq "windows"} {
jpayne@68 34 return [string equal -nocase [file extension $fileName] $ext]
jpayne@68 35 } else {
jpayne@68 36 # Some unices add trailing numbers after the .so, so
jpayne@68 37 # we could have something like '.so.1.2'.
jpayne@68 38 set root $fileName
jpayne@68 39 while {1} {
jpayne@68 40 set currExt [file extension $root]
jpayne@68 41 if {$currExt eq $ext} {
jpayne@68 42 return 1
jpayne@68 43 }
jpayne@68 44
jpayne@68 45 # The current extension does not match; if it is not a numeric
jpayne@68 46 # value, quit, as we are only looking to ignore version number
jpayne@68 47 # extensions. Otherwise we might return 1 in this case:
jpayne@68 48 # tcl::Pkg::CompareExtension foo.so.bar .so
jpayne@68 49 # which should not match.
jpayne@68 50
jpayne@68 51 if {![string is integer -strict [string range $currExt 1 end]]} {
jpayne@68 52 return 0
jpayne@68 53 }
jpayne@68 54 set root [file rootname $root]
jpayne@68 55 }
jpayne@68 56 }
jpayne@68 57 }
jpayne@68 58
jpayne@68 59 # pkg_mkIndex --
jpayne@68 60 # This procedure creates a package index in a given directory. The package
jpayne@68 61 # index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that
jpayne@68 62 # sets up package information with "package require" commands. The commands
jpayne@68 63 # describe all of the packages defined by the files given as arguments.
jpayne@68 64 #
jpayne@68 65 # Arguments:
jpayne@68 66 # -direct (optional) If this flag is present, the generated
jpayne@68 67 # code in pkgMkIndex.tcl will cause the package to be
jpayne@68 68 # loaded when "package require" is executed, rather
jpayne@68 69 # than lazily when the first reference to an exported
jpayne@68 70 # procedure in the package is made.
jpayne@68 71 # -verbose (optional) Verbose output; the name of each file that
jpayne@68 72 # was successfully rocessed is printed out. Additionally,
jpayne@68 73 # if processing of a file failed a message is printed.
jpayne@68 74 # -load pat (optional) Preload any packages whose names match
jpayne@68 75 # the pattern. Used to handle DLLs that depend on
jpayne@68 76 # other packages during their Init procedure.
jpayne@68 77 # dir - Name of the directory in which to create the index.
jpayne@68 78 # args - Any number of additional arguments, each giving
jpayne@68 79 # a glob pattern that matches the names of one or
jpayne@68 80 # more shared libraries or Tcl script files in
jpayne@68 81 # dir.
jpayne@68 82
jpayne@68 83 proc pkg_mkIndex {args} {
jpayne@68 84 set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"}
jpayne@68 85
jpayne@68 86 set argCount [llength $args]
jpayne@68 87 if {$argCount < 1} {
jpayne@68 88 return -code error "wrong # args: should be\n$usage"
jpayne@68 89 }
jpayne@68 90
jpayne@68 91 set more ""
jpayne@68 92 set direct 1
jpayne@68 93 set doVerbose 0
jpayne@68 94 set loadPat ""
jpayne@68 95 for {set idx 0} {$idx < $argCount} {incr idx} {
jpayne@68 96 set flag [lindex $args $idx]
jpayne@68 97 switch -glob -- $flag {
jpayne@68 98 -- {
jpayne@68 99 # done with the flags
jpayne@68 100 incr idx
jpayne@68 101 break
jpayne@68 102 }
jpayne@68 103 -verbose {
jpayne@68 104 set doVerbose 1
jpayne@68 105 }
jpayne@68 106 -lazy {
jpayne@68 107 set direct 0
jpayne@68 108 append more " -lazy"
jpayne@68 109 }
jpayne@68 110 -direct {
jpayne@68 111 append more " -direct"
jpayne@68 112 }
jpayne@68 113 -load {
jpayne@68 114 incr idx
jpayne@68 115 set loadPat [lindex $args $idx]
jpayne@68 116 append more " -load $loadPat"
jpayne@68 117 }
jpayne@68 118 -* {
jpayne@68 119 return -code error "unknown flag $flag: should be\n$usage"
jpayne@68 120 }
jpayne@68 121 default {
jpayne@68 122 # done with the flags
jpayne@68 123 break
jpayne@68 124 }
jpayne@68 125 }
jpayne@68 126 }
jpayne@68 127
jpayne@68 128 set dir [lindex $args $idx]
jpayne@68 129 set patternList [lrange $args [expr {$idx + 1}] end]
jpayne@68 130 if {![llength $patternList]} {
jpayne@68 131 set patternList [list "*.tcl" "*[info sharedlibextension]"]
jpayne@68 132 }
jpayne@68 133
jpayne@68 134 try {
jpayne@68 135 set fileList [glob -directory $dir -tails -types {r f} -- \
jpayne@68 136 {*}$patternList]
jpayne@68 137 } on error {msg opt} {
jpayne@68 138 return -options $opt $msg
jpayne@68 139 }
jpayne@68 140 foreach file $fileList {
jpayne@68 141 # For each file, figure out what commands and packages it provides.
jpayne@68 142 # To do this, create a child interpreter, load the file into the
jpayne@68 143 # interpreter, and get a list of the new commands and packages that
jpayne@68 144 # are defined.
jpayne@68 145
jpayne@68 146 if {$file eq "pkgIndex.tcl"} {
jpayne@68 147 continue
jpayne@68 148 }
jpayne@68 149
jpayne@68 150 set c [interp create]
jpayne@68 151
jpayne@68 152 # Load into the child any packages currently loaded in the parent
jpayne@68 153 # interpreter that match the -load pattern.
jpayne@68 154
jpayne@68 155 if {$loadPat ne ""} {
jpayne@68 156 if {$doVerbose} {
jpayne@68 157 tclLog "currently loaded packages: '[info loaded]'"
jpayne@68 158 tclLog "trying to load all packages matching $loadPat"
jpayne@68 159 }
jpayne@68 160 if {![llength [info loaded]]} {
jpayne@68 161 tclLog "warning: no packages are currently loaded, nothing"
jpayne@68 162 tclLog "can possibly match '$loadPat'"
jpayne@68 163 }
jpayne@68 164 }
jpayne@68 165 foreach pkg [info loaded] {
jpayne@68 166 if {![string match -nocase $loadPat [lindex $pkg 1]]} {
jpayne@68 167 continue
jpayne@68 168 }
jpayne@68 169 if {$doVerbose} {
jpayne@68 170 tclLog "package [lindex $pkg 1] matches '$loadPat'"
jpayne@68 171 }
jpayne@68 172 try {
jpayne@68 173 load [lindex $pkg 0] [lindex $pkg 1] $c
jpayne@68 174 } on error err {
jpayne@68 175 if {$doVerbose} {
jpayne@68 176 tclLog "warning: load [lindex $pkg 0]\
jpayne@68 177 [lindex $pkg 1]\nfailed with: $err"
jpayne@68 178 }
jpayne@68 179 } on ok {} {
jpayne@68 180 if {$doVerbose} {
jpayne@68 181 tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
jpayne@68 182 }
jpayne@68 183 }
jpayne@68 184 if {[lindex $pkg 1] eq "Tk"} {
jpayne@68 185 # Withdraw . if Tk was loaded, to avoid showing a window.
jpayne@68 186 $c eval [list wm withdraw .]
jpayne@68 187 }
jpayne@68 188 }
jpayne@68 189
jpayne@68 190 $c eval {
jpayne@68 191 # Stub out the package command so packages can require other
jpayne@68 192 # packages.
jpayne@68 193
jpayne@68 194 rename package __package_orig
jpayne@68 195 proc package {what args} {
jpayne@68 196 switch -- $what {
jpayne@68 197 require {
jpayne@68 198 return; # Ignore transitive requires
jpayne@68 199 }
jpayne@68 200 default {
jpayne@68 201 __package_orig $what {*}$args
jpayne@68 202 }
jpayne@68 203 }
jpayne@68 204 }
jpayne@68 205 proc tclPkgUnknown args {}
jpayne@68 206 package unknown tclPkgUnknown
jpayne@68 207
jpayne@68 208 # Stub out the unknown command so package can call into each other
jpayne@68 209 # during their initialilzation.
jpayne@68 210
jpayne@68 211 proc unknown {args} {}
jpayne@68 212
jpayne@68 213 # Stub out the auto_import mechanism
jpayne@68 214
jpayne@68 215 proc auto_import {args} {}
jpayne@68 216
jpayne@68 217 # reserve the ::tcl namespace for support procs and temporary
jpayne@68 218 # variables. This might make it awkward to generate a
jpayne@68 219 # pkgIndex.tcl file for the ::tcl namespace.
jpayne@68 220
jpayne@68 221 namespace eval ::tcl {
jpayne@68 222 variable dir ;# Current directory being processed
jpayne@68 223 variable file ;# Current file being processed
jpayne@68 224 variable direct ;# -direct flag value
jpayne@68 225 variable x ;# Loop variable
jpayne@68 226 variable debug ;# For debugging
jpayne@68 227 variable type ;# "load" or "source", for -direct
jpayne@68 228 variable namespaces ;# Existing namespaces (e.g., ::tcl)
jpayne@68 229 variable packages ;# Existing packages (e.g., Tcl)
jpayne@68 230 variable origCmds ;# Existing commands
jpayne@68 231 variable newCmds ;# Newly created commands
jpayne@68 232 variable newPkgs {} ;# Newly created packages
jpayne@68 233 }
jpayne@68 234 }
jpayne@68 235
jpayne@68 236 $c eval [list set ::tcl::dir $dir]
jpayne@68 237 $c eval [list set ::tcl::file $file]
jpayne@68 238 $c eval [list set ::tcl::direct $direct]
jpayne@68 239
jpayne@68 240 # Download needed procedures into the child because we've just deleted
jpayne@68 241 # the unknown procedure. This doesn't handle procedures with default
jpayne@68 242 # arguments.
jpayne@68 243
jpayne@68 244 foreach p {::tcl::Pkg::CompareExtension} {
jpayne@68 245 $c eval [list namespace eval [namespace qualifiers $p] {}]
jpayne@68 246 $c eval [list proc $p [info args $p] [info body $p]]
jpayne@68 247 }
jpayne@68 248
jpayne@68 249 try {
jpayne@68 250 $c eval {
jpayne@68 251 set ::tcl::debug "loading or sourcing"
jpayne@68 252
jpayne@68 253 # we need to track command defined by each package even in the
jpayne@68 254 # -direct case, because they are needed internally by the
jpayne@68 255 # "partial pkgIndex.tcl" step above.
jpayne@68 256
jpayne@68 257 proc ::tcl::GetAllNamespaces {{root ::}} {
jpayne@68 258 set list $root
jpayne@68 259 foreach ns [namespace children $root] {
jpayne@68 260 lappend list {*}[::tcl::GetAllNamespaces $ns]
jpayne@68 261 }
jpayne@68 262 return $list
jpayne@68 263 }
jpayne@68 264
jpayne@68 265 # init the list of existing namespaces, packages, commands
jpayne@68 266
jpayne@68 267 foreach ::tcl::x [::tcl::GetAllNamespaces] {
jpayne@68 268 set ::tcl::namespaces($::tcl::x) 1
jpayne@68 269 }
jpayne@68 270 foreach ::tcl::x [package names] {
jpayne@68 271 if {[package provide $::tcl::x] ne ""} {
jpayne@68 272 set ::tcl::packages($::tcl::x) 1
jpayne@68 273 }
jpayne@68 274 }
jpayne@68 275 set ::tcl::origCmds [info commands]
jpayne@68 276
jpayne@68 277 # Try to load the file if it has the shared library extension,
jpayne@68 278 # otherwise source it. It's important not to try to load
jpayne@68 279 # files that aren't shared libraries, because on some systems
jpayne@68 280 # (like SunOS) the loader will abort the whole application
jpayne@68 281 # when it gets an error.
jpayne@68 282
jpayne@68 283 if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension]]} {
jpayne@68 284 # The "file join ." command below is necessary. Without
jpayne@68 285 # it, if the file name has no \'s and we're on UNIX, the
jpayne@68 286 # load command will invoke the LD_LIBRARY_PATH search
jpayne@68 287 # mechanism, which could cause the wrong file to be used.
jpayne@68 288
jpayne@68 289 set ::tcl::debug loading
jpayne@68 290 load [file join $::tcl::dir $::tcl::file]
jpayne@68 291 set ::tcl::type load
jpayne@68 292 } else {
jpayne@68 293 set ::tcl::debug sourcing
jpayne@68 294 source [file join $::tcl::dir $::tcl::file]
jpayne@68 295 set ::tcl::type source
jpayne@68 296 }
jpayne@68 297
jpayne@68 298 # As a performance optimization, if we are creating direct
jpayne@68 299 # load packages, don't bother figuring out the set of commands
jpayne@68 300 # created by the new packages. We only need that list for
jpayne@68 301 # setting up the autoloading used in the non-direct case.
jpayne@68 302 if {!$::tcl::direct} {
jpayne@68 303 # See what new namespaces appeared, and import commands
jpayne@68 304 # from them. Only exported commands go into the index.
jpayne@68 305
jpayne@68 306 foreach ::tcl::x [::tcl::GetAllNamespaces] {
jpayne@68 307 if {![info exists ::tcl::namespaces($::tcl::x)]} {
jpayne@68 308 namespace import -force ${::tcl::x}::*
jpayne@68 309 }
jpayne@68 310
jpayne@68 311 # Figure out what commands appeared
jpayne@68 312
jpayne@68 313 foreach ::tcl::x [info commands] {
jpayne@68 314 set ::tcl::newCmds($::tcl::x) 1
jpayne@68 315 }
jpayne@68 316 foreach ::tcl::x $::tcl::origCmds {
jpayne@68 317 unset -nocomplain ::tcl::newCmds($::tcl::x)
jpayne@68 318 }
jpayne@68 319 foreach ::tcl::x [array names ::tcl::newCmds] {
jpayne@68 320 # determine which namespace a command comes from
jpayne@68 321
jpayne@68 322 set ::tcl::abs [namespace origin $::tcl::x]
jpayne@68 323
jpayne@68 324 # special case so that global names have no
jpayne@68 325 # leading ::, this is required by the unknown
jpayne@68 326 # command
jpayne@68 327
jpayne@68 328 set ::tcl::abs \
jpayne@68 329 [lindex [auto_qualify $::tcl::abs ::] 0]
jpayne@68 330
jpayne@68 331 if {$::tcl::x ne $::tcl::abs} {
jpayne@68 332 # Name changed during qualification
jpayne@68 333
jpayne@68 334 set ::tcl::newCmds($::tcl::abs) 1
jpayne@68 335 unset ::tcl::newCmds($::tcl::x)
jpayne@68 336 }
jpayne@68 337 }
jpayne@68 338 }
jpayne@68 339 }
jpayne@68 340
jpayne@68 341 # Look through the packages that appeared, and if there is a
jpayne@68 342 # version provided, then record it
jpayne@68 343
jpayne@68 344 foreach ::tcl::x [package names] {
jpayne@68 345 if {[package provide $::tcl::x] ne ""
jpayne@68 346 && ![info exists ::tcl::packages($::tcl::x)]} {
jpayne@68 347 lappend ::tcl::newPkgs \
jpayne@68 348 [list $::tcl::x [package provide $::tcl::x]]
jpayne@68 349 }
jpayne@68 350 }
jpayne@68 351 }
jpayne@68 352 } on error msg {
jpayne@68 353 set what [$c eval set ::tcl::debug]
jpayne@68 354 if {$doVerbose} {
jpayne@68 355 tclLog "warning: error while $what $file: $msg"
jpayne@68 356 }
jpayne@68 357 } on ok {} {
jpayne@68 358 set what [$c eval set ::tcl::debug]
jpayne@68 359 if {$doVerbose} {
jpayne@68 360 tclLog "successful $what of $file"
jpayne@68 361 }
jpayne@68 362 set type [$c eval set ::tcl::type]
jpayne@68 363 set cmds [lsort [$c eval array names ::tcl::newCmds]]
jpayne@68 364 set pkgs [$c eval set ::tcl::newPkgs]
jpayne@68 365 if {$doVerbose} {
jpayne@68 366 if {!$direct} {
jpayne@68 367 tclLog "commands provided were $cmds"
jpayne@68 368 }
jpayne@68 369 tclLog "packages provided were $pkgs"
jpayne@68 370 }
jpayne@68 371 if {[llength $pkgs] > 1} {
jpayne@68 372 tclLog "warning: \"$file\" provides more than one package ($pkgs)"
jpayne@68 373 }
jpayne@68 374 foreach pkg $pkgs {
jpayne@68 375 # cmds is empty/not used in the direct case
jpayne@68 376 lappend files($pkg) [list $file $type $cmds]
jpayne@68 377 }
jpayne@68 378
jpayne@68 379 if {$doVerbose} {
jpayne@68 380 tclLog "processed $file"
jpayne@68 381 }
jpayne@68 382 }
jpayne@68 383 interp delete $c
jpayne@68 384 }
jpayne@68 385
jpayne@68 386 append index "# Tcl package index file, version 1.1\n"
jpayne@68 387 append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
jpayne@68 388 append index "# and sourced either when an application starts up or\n"
jpayne@68 389 append index "# by a \"package unknown\" script. It invokes the\n"
jpayne@68 390 append index "# \"package ifneeded\" command to set up package-related\n"
jpayne@68 391 append index "# information so that packages will be loaded automatically\n"
jpayne@68 392 append index "# in response to \"package require\" commands. When this\n"
jpayne@68 393 append index "# script is sourced, the variable \$dir must contain the\n"
jpayne@68 394 append index "# full path name of this file's directory.\n"
jpayne@68 395
jpayne@68 396 foreach pkg [lsort [array names files]] {
jpayne@68 397 set cmd {}
jpayne@68 398 lassign $pkg name version
jpayne@68 399 lappend cmd ::tcl::Pkg::Create -name $name -version $version
jpayne@68 400 foreach spec [lsort -index 0 $files($pkg)] {
jpayne@68 401 foreach {file type procs} $spec {
jpayne@68 402 if {$direct} {
jpayne@68 403 set procs {}
jpayne@68 404 }
jpayne@68 405 lappend cmd "-$type" [list $file $procs]
jpayne@68 406 }
jpayne@68 407 }
jpayne@68 408 append index "\n[eval $cmd]"
jpayne@68 409 }
jpayne@68 410
jpayne@68 411 set f [open [file join $dir pkgIndex.tcl] w]
jpayne@68 412 puts $f $index
jpayne@68 413 close $f
jpayne@68 414 }
jpayne@68 415
jpayne@68 416 # tclPkgSetup --
jpayne@68 417 # This is a utility procedure use by pkgIndex.tcl files. It is invoked as
jpayne@68 418 # part of a "package ifneeded" script. It calls "package provide" to indicate
jpayne@68 419 # that a package is available, then sets entries in the auto_index array so
jpayne@68 420 # that the package's files will be auto-loaded when the commands are used.
jpayne@68 421 #
jpayne@68 422 # Arguments:
jpayne@68 423 # dir - Directory containing all the files for this package.
jpayne@68 424 # pkg - Name of the package (no version number).
jpayne@68 425 # version - Version number for the package, such as 2.1.3.
jpayne@68 426 # files - List of files that constitute the package. Each
jpayne@68 427 # element is a sub-list with three elements. The first
jpayne@68 428 # is the name of a file relative to $dir, the second is
jpayne@68 429 # "load" or "source", indicating whether the file is a
jpayne@68 430 # loadable binary or a script to source, and the third
jpayne@68 431 # is a list of commands defined by this file.
jpayne@68 432
jpayne@68 433 proc tclPkgSetup {dir pkg version files} {
jpayne@68 434 global auto_index
jpayne@68 435
jpayne@68 436 package provide $pkg $version
jpayne@68 437 foreach fileInfo $files {
jpayne@68 438 set f [lindex $fileInfo 0]
jpayne@68 439 set type [lindex $fileInfo 1]
jpayne@68 440 foreach cmd [lindex $fileInfo 2] {
jpayne@68 441 if {$type eq "load"} {
jpayne@68 442 set auto_index($cmd) [list load [file join $dir $f] $pkg]
jpayne@68 443 } else {
jpayne@68 444 set auto_index($cmd) [list source [file join $dir $f]]
jpayne@68 445 }
jpayne@68 446 }
jpayne@68 447 }
jpayne@68 448 }
jpayne@68 449
jpayne@68 450 # tclPkgUnknown --
jpayne@68 451 # This procedure provides the default for the "package unknown" function. It
jpayne@68 452 # is invoked when a package that's needed can't be found. It scans the
jpayne@68 453 # auto_path directories and their immediate children looking for pkgIndex.tcl
jpayne@68 454 # files and sources any such files that are found to setup the package
jpayne@68 455 # database. As it searches, it will recognize changes to the auto_path and
jpayne@68 456 # scan any new directories.
jpayne@68 457 #
jpayne@68 458 # Arguments:
jpayne@68 459 # name - Name of desired package. Not used.
jpayne@68 460 # version - Version of desired package. Not used.
jpayne@68 461 # exact - Either "-exact" or omitted. Not used.
jpayne@68 462
jpayne@68 463 proc tclPkgUnknown {name args} {
jpayne@68 464 global auto_path env
jpayne@68 465
jpayne@68 466 if {![info exists auto_path]} {
jpayne@68 467 return
jpayne@68 468 }
jpayne@68 469 # Cache the auto_path, because it may change while we run through the
jpayne@68 470 # first set of pkgIndex.tcl files
jpayne@68 471 set old_path [set use_path $auto_path]
jpayne@68 472 while {[llength $use_path]} {
jpayne@68 473 set dir [lindex $use_path end]
jpayne@68 474
jpayne@68 475 # Make sure we only scan each directory one time.
jpayne@68 476 if {[info exists tclSeenPath($dir)]} {
jpayne@68 477 set use_path [lrange $use_path 0 end-1]
jpayne@68 478 continue
jpayne@68 479 }
jpayne@68 480 set tclSeenPath($dir) 1
jpayne@68 481
jpayne@68 482 # Get the pkgIndex.tcl files in subdirectories of auto_path directories.
jpayne@68 483 # - Safe Base interpreters have a restricted "glob" command that
jpayne@68 484 # works in this case.
jpayne@68 485 # - The "catch" was essential when there was no safe glob and every
jpayne@68 486 # call in a safe interp failed; it is retained only for corner
jpayne@68 487 # cases in which the eventual call to glob returns an error.
jpayne@68 488 catch {
jpayne@68 489 foreach file [glob -directory $dir -join -nocomplain \
jpayne@68 490 * pkgIndex.tcl] {
jpayne@68 491 set dir [file dirname $file]
jpayne@68 492 if {![info exists procdDirs($dir)]} {
jpayne@68 493 try {
jpayne@68 494 source $file
jpayne@68 495 } trap {POSIX EACCES} {} {
jpayne@68 496 # $file was not readable; silently ignore
jpayne@68 497 continue
jpayne@68 498 } on error msg {
jpayne@68 499 tclLog "error reading package index file $file: $msg"
jpayne@68 500 } on ok {} {
jpayne@68 501 set procdDirs($dir) 1
jpayne@68 502 }
jpayne@68 503 }
jpayne@68 504 }
jpayne@68 505 }
jpayne@68 506 set dir [lindex $use_path end]
jpayne@68 507 if {![info exists procdDirs($dir)]} {
jpayne@68 508 set file [file join $dir pkgIndex.tcl]
jpayne@68 509 # safe interps usually don't have "file exists",
jpayne@68 510 if {([interp issafe] || [file exists $file])} {
jpayne@68 511 try {
jpayne@68 512 source $file
jpayne@68 513 } trap {POSIX EACCES} {} {
jpayne@68 514 # $file was not readable; silently ignore
jpayne@68 515 continue
jpayne@68 516 } on error msg {
jpayne@68 517 tclLog "error reading package index file $file: $msg"
jpayne@68 518 } on ok {} {
jpayne@68 519 set procdDirs($dir) 1
jpayne@68 520 }
jpayne@68 521 }
jpayne@68 522 }
jpayne@68 523
jpayne@68 524 set use_path [lrange $use_path 0 end-1]
jpayne@68 525
jpayne@68 526 # Check whether any of the index scripts we [source]d above set a new
jpayne@68 527 # value for $::auto_path. If so, then find any new directories on the
jpayne@68 528 # $::auto_path, and lappend them to the $use_path we are working from.
jpayne@68 529 # This gives index scripts the (arguably unwise) power to expand the
jpayne@68 530 # index script search path while the search is in progress.
jpayne@68 531 set index 0
jpayne@68 532 if {[llength $old_path] == [llength $auto_path]} {
jpayne@68 533 foreach dir $auto_path old $old_path {
jpayne@68 534 if {$dir ne $old} {
jpayne@68 535 # This entry in $::auto_path has changed.
jpayne@68 536 break
jpayne@68 537 }
jpayne@68 538 incr index
jpayne@68 539 }
jpayne@68 540 }
jpayne@68 541
jpayne@68 542 # $index now points to the first element of $auto_path that has
jpayne@68 543 # changed, or the beginning if $auto_path has changed length Scan the
jpayne@68 544 # new elements of $auto_path for directories to add to $use_path.
jpayne@68 545 # Don't add directories we've already seen, or ones already on the
jpayne@68 546 # $use_path.
jpayne@68 547 foreach dir [lrange $auto_path $index end] {
jpayne@68 548 if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
jpayne@68 549 lappend use_path $dir
jpayne@68 550 }
jpayne@68 551 }
jpayne@68 552 set old_path $auto_path
jpayne@68 553 }
jpayne@68 554 }
jpayne@68 555
jpayne@68 556 # tcl::MacOSXPkgUnknown --
jpayne@68 557 # This procedure extends the "package unknown" function for MacOSX. It scans
jpayne@68 558 # the Resources/Scripts directories of the immediate children of the auto_path
jpayne@68 559 # directories for pkgIndex files.
jpayne@68 560 #
jpayne@68 561 # Arguments:
jpayne@68 562 # original - original [package unknown] procedure
jpayne@68 563 # name - Name of desired package. Not used.
jpayne@68 564 # version - Version of desired package. Not used.
jpayne@68 565 # exact - Either "-exact" or omitted. Not used.
jpayne@68 566
jpayne@68 567 proc tcl::MacOSXPkgUnknown {original name args} {
jpayne@68 568 # First do the cross-platform default search
jpayne@68 569 uplevel 1 $original [linsert $args 0 $name]
jpayne@68 570
jpayne@68 571 # Now do MacOSX specific searching
jpayne@68 572 global auto_path
jpayne@68 573
jpayne@68 574 if {![info exists auto_path]} {
jpayne@68 575 return
jpayne@68 576 }
jpayne@68 577 # Cache the auto_path, because it may change while we run through the
jpayne@68 578 # first set of pkgIndex.tcl files
jpayne@68 579 set old_path [set use_path $auto_path]
jpayne@68 580 while {[llength $use_path]} {
jpayne@68 581 set dir [lindex $use_path end]
jpayne@68 582
jpayne@68 583 # Make sure we only scan each directory one time.
jpayne@68 584 if {[info exists tclSeenPath($dir)]} {
jpayne@68 585 set use_path [lrange $use_path 0 end-1]
jpayne@68 586 continue
jpayne@68 587 }
jpayne@68 588 set tclSeenPath($dir) 1
jpayne@68 589
jpayne@68 590 # get the pkgIndex files out of the subdirectories
jpayne@68 591 # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl.
jpayne@68 592 foreach file [glob -directory $dir -join -nocomplain \
jpayne@68 593 * Resources Scripts pkgIndex.tcl] {
jpayne@68 594 set dir [file dirname $file]
jpayne@68 595 if {![info exists procdDirs($dir)]} {
jpayne@68 596 try {
jpayne@68 597 source $file
jpayne@68 598 } trap {POSIX EACCES} {} {
jpayne@68 599 # $file was not readable; silently ignore
jpayne@68 600 continue
jpayne@68 601 } on error msg {
jpayne@68 602 tclLog "error reading package index file $file: $msg"
jpayne@68 603 } on ok {} {
jpayne@68 604 set procdDirs($dir) 1
jpayne@68 605 }
jpayne@68 606 }
jpayne@68 607 }
jpayne@68 608 set use_path [lrange $use_path 0 end-1]
jpayne@68 609
jpayne@68 610 # Check whether any of the index scripts we [source]d above set a new
jpayne@68 611 # value for $::auto_path. If so, then find any new directories on the
jpayne@68 612 # $::auto_path, and lappend them to the $use_path we are working from.
jpayne@68 613 # This gives index scripts the (arguably unwise) power to expand the
jpayne@68 614 # index script search path while the search is in progress.
jpayne@68 615 set index 0
jpayne@68 616 if {[llength $old_path] == [llength $auto_path]} {
jpayne@68 617 foreach dir $auto_path old $old_path {
jpayne@68 618 if {$dir ne $old} {
jpayne@68 619 # This entry in $::auto_path has changed.
jpayne@68 620 break
jpayne@68 621 }
jpayne@68 622 incr index
jpayne@68 623 }
jpayne@68 624 }
jpayne@68 625
jpayne@68 626 # $index now points to the first element of $auto_path that has
jpayne@68 627 # changed, or the beginning if $auto_path has changed length Scan the
jpayne@68 628 # new elements of $auto_path for directories to add to $use_path.
jpayne@68 629 # Don't add directories we've already seen, or ones already on the
jpayne@68 630 # $use_path.
jpayne@68 631 foreach dir [lrange $auto_path $index end] {
jpayne@68 632 if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
jpayne@68 633 lappend use_path $dir
jpayne@68 634 }
jpayne@68 635 }
jpayne@68 636 set old_path $auto_path
jpayne@68 637 }
jpayne@68 638 }
jpayne@68 639
jpayne@68 640 # ::tcl::Pkg::Create --
jpayne@68 641 #
jpayne@68 642 # Given a package specification generate a "package ifneeded" statement
jpayne@68 643 # for the package, suitable for inclusion in a pkgIndex.tcl file.
jpayne@68 644 #
jpayne@68 645 # Arguments:
jpayne@68 646 # args arguments used by the Create function:
jpayne@68 647 # -name packageName
jpayne@68 648 # -version packageVersion
jpayne@68 649 # -load {filename ?{procs}?}
jpayne@68 650 # ...
jpayne@68 651 # -source {filename ?{procs}?}
jpayne@68 652 # ...
jpayne@68 653 #
jpayne@68 654 # Any number of -load and -source parameters may be
jpayne@68 655 # specified, so long as there is at least one -load or
jpayne@68 656 # -source parameter. If the procs component of a module
jpayne@68 657 # specifier is left off, that module will be set up for
jpayne@68 658 # direct loading; otherwise, it will be set up for lazy
jpayne@68 659 # loading. If both -source and -load are specified, the
jpayne@68 660 # -load'ed files will be loaded first, followed by the
jpayne@68 661 # -source'd files.
jpayne@68 662 #
jpayne@68 663 # Results:
jpayne@68 664 # An appropriate "package ifneeded" statement for the package.
jpayne@68 665
jpayne@68 666 proc ::tcl::Pkg::Create {args} {
jpayne@68 667 append err(usage) "[lindex [info level 0] 0] "
jpayne@68 668 append err(usage) "-name packageName -version packageVersion"
jpayne@68 669 append err(usage) "?-load {filename ?{procs}?}? ... "
jpayne@68 670 append err(usage) "?-source {filename ?{procs}?}? ..."
jpayne@68 671
jpayne@68 672 set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
jpayne@68 673 set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
jpayne@68 674 set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\""
jpayne@68 675 set err(noLoadOrSource) "at least one of -load and -source must be given"
jpayne@68 676
jpayne@68 677 # process arguments
jpayne@68 678 set len [llength $args]
jpayne@68 679 if {$len < 6} {
jpayne@68 680 error $err(wrongNumArgs)
jpayne@68 681 }
jpayne@68 682
jpayne@68 683 # Initialize parameters
jpayne@68 684 array set opts {-name {} -version {} -source {} -load {}}
jpayne@68 685
jpayne@68 686 # process parameters
jpayne@68 687 for {set i 0} {$i < $len} {incr i} {
jpayne@68 688 set flag [lindex $args $i]
jpayne@68 689 incr i
jpayne@68 690 switch -glob -- $flag {
jpayne@68 691 "-name" -
jpayne@68 692 "-version" {
jpayne@68 693 if {$i >= $len} {
jpayne@68 694 error [format $err(valueMissing) $flag]
jpayne@68 695 }
jpayne@68 696 set opts($flag) [lindex $args $i]
jpayne@68 697 }
jpayne@68 698 "-source" -
jpayne@68 699 "-load" {
jpayne@68 700 if {$i >= $len} {
jpayne@68 701 error [format $err(valueMissing) $flag]
jpayne@68 702 }
jpayne@68 703 lappend opts($flag) [lindex $args $i]
jpayne@68 704 }
jpayne@68 705 default {
jpayne@68 706 error [format $err(unknownOpt) [lindex $args $i]]
jpayne@68 707 }
jpayne@68 708 }
jpayne@68 709 }
jpayne@68 710
jpayne@68 711 # Validate the parameters
jpayne@68 712 if {![llength $opts(-name)]} {
jpayne@68 713 error [format $err(valueMissing) "-name"]
jpayne@68 714 }
jpayne@68 715 if {![llength $opts(-version)]} {
jpayne@68 716 error [format $err(valueMissing) "-version"]
jpayne@68 717 }
jpayne@68 718
jpayne@68 719 if {!([llength $opts(-source)] || [llength $opts(-load)])} {
jpayne@68 720 error $err(noLoadOrSource)
jpayne@68 721 }
jpayne@68 722
jpayne@68 723 # OK, now everything is good. Generate the package ifneeded statment.
jpayne@68 724 set cmdline "package ifneeded $opts(-name) $opts(-version) "
jpayne@68 725
jpayne@68 726 set cmdList {}
jpayne@68 727 set lazyFileList {}
jpayne@68 728
jpayne@68 729 # Handle -load and -source specs
jpayne@68 730 foreach key {load source} {
jpayne@68 731 foreach filespec $opts(-$key) {
jpayne@68 732 lassign $filespec filename proclist
jpayne@68 733
jpayne@68 734 if { [llength $proclist] == 0 } {
jpayne@68 735 set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
jpayne@68 736 lappend cmdList $cmd
jpayne@68 737 } else {
jpayne@68 738 lappend lazyFileList [list $filename $key $proclist]
jpayne@68 739 }
jpayne@68 740 }
jpayne@68 741 }
jpayne@68 742
jpayne@68 743 if {[llength $lazyFileList]} {
jpayne@68 744 lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
jpayne@68 745 $opts(-version) [list $lazyFileList]\]"
jpayne@68 746 }
jpayne@68 747 append cmdline [join $cmdList "\\n"]
jpayne@68 748 return $cmdline
jpayne@68 749 }
jpayne@68 750
jpayne@68 751 interp alias {} ::pkg::create {} ::tcl::Pkg::Create