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