package.tcl
上传用户:rrhhcc
上传日期:2015-12-11
资源大小:54129k
文件大小:25k
源码类别:

通讯编程

开发平台:

Visual C++

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