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