Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/package.tcl @ 69:33d812a61356

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