util/X86LINUX64/lib/tcl8.6/package.tcl

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