diff options
Diffstat (limited to 'library/package.tcl')
| -rw-r--r-- | library/package.tcl | 667 |
1 files changed, 471 insertions, 196 deletions
diff --git a/library/package.tcl b/library/package.tcl index 22b46d1..52daa0e 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -3,8 +3,6 @@ # utility procs formerly in init.tcl which can be loaded on demand # for package management. # -# RCS: @(#) $Id: package.tcl,v 1.6 1999/08/19 02:59:40 hobbs Exp $ -# # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # @@ -12,11 +10,13 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# pkg_compareExtension -- +namespace eval tcl::Pkg {} + +# ::tcl::Pkg::CompareExtension -- # -# Used internally by pkg_mkIndex to compare the extension of a file to -# a given extension. On Windows, it uses a case-insensitive comparison -# because the file system can be file insensitive. +# Used internally by pkg_mkIndex to compare the extension of a file to a given +# extension. On Windows, it uses a case-insensitive comparison because the +# file system can be file insensitive. # # Arguments: # fileName name of a file whose extension is compared @@ -27,24 +27,40 @@ # Results: # Returns 1 if the extension matches, 0 otherwise -proc pkg_compareExtension { fileName {ext {}} } { +proc tcl::Pkg::CompareExtension {fileName {ext {}}} { global tcl_platform - if {[string length $ext] == 0} { - set ext [info sharedlibextension] - } - if {[string equal $tcl_platform(platform) "windows"]} { - return [string equal -nocase [file extension $fileName] $ext] + if {$ext eq ""} {set ext [info sharedlibextension]} + if {$tcl_platform(platform) eq "windows"} { + return [string equal -nocase [file extension $fileName] $ext] } else { - return [string equal [file extension $fileName] $ext] + # Some unices add trailing numbers after the .so, so + # we could have something like '.so.1.2'. + set root $fileName + while {1} { + set currExt [file extension $root] + if {$currExt eq $ext} { + return 1 + } + + # The current extension does not match; if it is not a numeric + # value, quit, as we are only looking to ignore version number + # extensions. Otherwise we might return 1 in this case: + # tcl::Pkg::CompareExtension foo.so.bar .so + # which should not match. + + if {![string is integer -strict [string range $currExt 1 end]]} { + return 0 + } + set root [file rootname $root] + } } } # pkg_mkIndex -- -# This procedure creates a package index in a given directory. The -# package index consists of a "pkgIndex.tcl" file whose contents are -# a Tcl script that sets up package information with "package require" -# commands. The commands describe all of the packages defined by the -# files given as arguments. +# This procedure creates a package index in a given directory. The package +# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that +# sets up package information with "package require" commands. The commands +# describe all of the packages defined by the files given as arguments. # # Arguments: # -direct (optional) If this flag is present, the generated @@ -65,8 +81,7 @@ proc pkg_compareExtension { fileName {ext {}} } { # dir. proc pkg_mkIndex {args} { - global errorCode errorInfo - set usage {"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?"}; + set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"} set argCount [llength $args] if {$argCount < 1} { @@ -74,7 +89,7 @@ proc pkg_mkIndex {args} { } set more "" - set direct 0 + set direct 1 set doVerbose 0 set loadPat "" for {set idx 0} {$idx < $argCount} {incr idx} { @@ -88,8 +103,11 @@ proc pkg_mkIndex {args} { -verbose { set doVerbose 1 } + -lazy { + set direct 0 + append more " -lazy" + } -direct { - set direct 1 append more " -direct" } -load { @@ -109,82 +127,86 @@ proc pkg_mkIndex {args} { set dir [lindex $args $idx] set patternList [lrange $args [expr {$idx + 1}] end] - if {[llength $patternList] == 0} { + if {![llength $patternList]} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } - append index "# Tcl package index file, version 1.1\n" - append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" - append index "# and sourced either when an application starts up or\n" - append index "# by a \"package unknown\" script. It invokes the\n" - append index "# \"package ifneeded\" command to set up package-related\n" - append index "# information so that packages will be loaded automatically\n" - append index "# in response to \"package require\" commands. When this\n" - append index "# script is sourced, the variable \$dir must contain the\n" - append index "# full path name of this file's directory.\n" - set oldDir [pwd] - cd $dir - - if {[catch {eval glob $patternList} fileList]} { - global errorCode errorInfo - cd $oldDir - return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList + try { + set fileList [glob -directory $dir -tails -types {r f} -- \ + {*}$patternList] + } on error {msg opt} { + return -options $opt $msg } foreach file $fileList { # For each file, figure out what commands and packages it provides. # To do this, create a child interpreter, load the file into the - # interpreter, and get a list of the new commands and packages - # that are defined. + # interpreter, and get a list of the new commands and packages that + # are defined. - if {[string equal $file "pkgIndex.tcl"]} { + if {$file eq "pkgIndex.tcl"} { continue } - # Changed back to the original directory before initializing the - # slave in case TCL_LIBRARY is a relative path (e.g. in the test - # suite). - - cd $oldDir set c [interp create] # Load into the child any packages currently loaded in the parent # interpreter that match the -load pattern. + if {$loadPat ne ""} { + if {$doVerbose} { + tclLog "currently loaded packages: '[info loaded]'" + tclLog "trying to load all packages matching $loadPat" + } + if {![llength [info loaded]]} { + tclLog "warning: no packages are currently loaded, nothing" + tclLog "can possibly match '$loadPat'" + } + } foreach pkg [info loaded] { - if {! [string match $loadPat [lindex $pkg 1]]} { + if {![string match -nocase $loadPat [lindex $pkg 1]]} { continue } - if {[string equal [lindex $pkg 1] "Tk"]} { - $c eval {set argv {-geometry +0+0}} + if {$doVerbose} { + tclLog "package [lindex $pkg 1] matches '$loadPat'" } - if {[catch { + try { load [lindex $pkg 0] [lindex $pkg 1] $c - } err]} { + } on error err { + if {$doVerbose} { + tclLog "warning: load [lindex $pkg 0]\ + [lindex $pkg 1]\nfailed with: $err" + } + } on ok {} { if {$doVerbose} { - tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err" + tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" } - } elseif {$doVerbose} { - tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" + } + if {[lindex $pkg 1] eq "Tk"} { + # Withdraw . if Tk was loaded, to avoid showing a window. + $c eval [list wm withdraw .] } } - cd $dir $c eval { - # Stub out the package command so packages can - # require other packages. + # Stub out the package command so packages can require other + # packages. rename package __package_orig proc package {what args} { switch -- $what { - require { return ; # ignore transitive requires } - default { eval __package_orig {$what} $args } + require { + return; # Ignore transitive requires + } + default { + __package_orig $what {*}$args + } } } proc tclPkgUnknown args {} package unknown tclPkgUnknown - # Stub out the unknown command so package can call - # into each other during their initialilzation. + # Stub out the unknown command so package can call into each other + # during their initialilzation. proc unknown {args} {} @@ -192,11 +214,12 @@ proc pkg_mkIndex {args} { proc auto_import {args} {} - # reserve the ::tcl namespace for support procs - # and temporary variables. This might make it awkward - # to generate a pkgIndex.tcl file for the ::tcl namespace. + # reserve the ::tcl namespace for support procs and temporary + # variables. This might make it awkward to generate a + # pkgIndex.tcl file for the ::tcl namespace. namespace eval ::tcl { + variable dir ;# Current directory being processed variable file ;# Current file being processed variable direct ;# -direct flag value variable x ;# Loop variable @@ -210,29 +233,31 @@ proc pkg_mkIndex {args} { } } + $c eval [list set ::tcl::dir $dir] $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] - # Download needed procedures into the slave because we've - # just deleted the unknown procedure. This doesn't handle - # procedures with default arguments. + # Download needed procedures into the slave because we've just deleted + # the unknown procedure. This doesn't handle procedures with default + # arguments. - foreach p {pkg_compareExtension} { + foreach p {::tcl::Pkg::CompareExtension} { + $c eval [list namespace eval [namespace qualifiers $p] {}] $c eval [list proc $p [info args $p] [info body $p]] } - if {[catch { + try { $c eval { set ::tcl::debug "loading or sourcing" - # we need to track command defined by each package even in - # the -direct case, because they are needed internally by - # the "partial pkgIndex.tcl" step above. + # we need to track command defined by each package even in the + # -direct case, because they are needed internally by the + # "partial pkgIndex.tcl" step above. proc ::tcl::GetAllNamespaces {{root ::}} { set list $root foreach ns [namespace children $root] { - eval lappend list [::tcl::GetAllNamespaces $ns] + lappend list {*}[::tcl::GetAllNamespaces $ns] } return $list } @@ -243,87 +268,106 @@ proc pkg_mkIndex {args} { set ::tcl::namespaces($::tcl::x) 1 } foreach ::tcl::x [package names] { - set ::tcl::packages($::tcl::x) 1 + if {[package provide $::tcl::x] ne ""} { + set ::tcl::packages($::tcl::x) 1 + } } set ::tcl::origCmds [info commands] - # Try to load the file if it has the shared library - # extension, otherwise source it. It's important not to - # try to load files that aren't shared libraries, because - # on some systems (like SunOS) the loader will abort the - # whole application when it gets an error. + # Try to load the file if it has the shared library extension, + # otherwise source it. It's important not to try to load + # files that aren't shared libraries, because on some systems + # (like SunOS) the loader will abort the whole application + # when it gets an error. - if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} { - # The "file join ." command below is necessary. - # Without it, if the file name has no \'s and we're - # on UNIX, the load command will invoke the - # LD_LIBRARY_PATH search mechanism, which could cause - # the wrong file to be used. + if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension]]} { + # The "file join ." command below is necessary. Without + # it, if the file name has no \'s and we're on UNIX, the + # load command will invoke the LD_LIBRARY_PATH search + # mechanism, which could cause the wrong file to be used. set ::tcl::debug loading - load [file join . $::tcl::file] + load [file join $::tcl::dir $::tcl::file] set ::tcl::type load } else { set ::tcl::debug sourcing - source $::tcl::file + source [file join $::tcl::dir $::tcl::file] set ::tcl::type source } - # See what new namespaces appeared, and import commands - # from them. Only exported commands go into the index. - - foreach ::tcl::x [::tcl::GetAllNamespaces] { - if {! [info exists ::tcl::namespaces($::tcl::x)]} { - namespace import -force ${::tcl::x}::* - } - } - - # Figure out what commands appeared - - foreach ::tcl::x [info commands] { - set ::tcl::newCmds($::tcl::x) 1 - } - foreach ::tcl::x $::tcl::origCmds { - catch {unset ::tcl::newCmds($::tcl::x)} - } - foreach ::tcl::x [array names ::tcl::newCmds] { - # reverse engineer which namespace a command comes from - - set ::tcl::abs [namespace origin $::tcl::x] - - # special case so that global names have no leading - # ::, this is required by the unknown command - - set ::tcl::abs [auto_qualify $::tcl::abs ::] - - if {[string compare $::tcl::x $::tcl::abs]} { - # Name changed during qualification - - set ::tcl::newCmds($::tcl::abs) 1 - unset ::tcl::newCmds($::tcl::x) + # As a performance optimization, if we are creating direct + # load packages, don't bother figuring out the set of commands + # created by the new packages. We only need that list for + # setting up the autoloading used in the non-direct case. + if {!$::tcl::direct} { + # See what new namespaces appeared, and import commands + # from them. Only exported commands go into the index. + + foreach ::tcl::x [::tcl::GetAllNamespaces] { + if {![info exists ::tcl::namespaces($::tcl::x)]} { + namespace import -force ${::tcl::x}::* + } + + # Figure out what commands appeared + + foreach ::tcl::x [info commands] { + set ::tcl::newCmds($::tcl::x) 1 + } + foreach ::tcl::x $::tcl::origCmds { + unset -nocomplain ::tcl::newCmds($::tcl::x) + } + foreach ::tcl::x [array names ::tcl::newCmds] { + # determine which namespace a command comes from + + set ::tcl::abs [namespace origin $::tcl::x] + + # special case so that global names have no + # leading ::, this is required by the unknown + # command + + set ::tcl::abs \ + [lindex [auto_qualify $::tcl::abs ::] 0] + + if {$::tcl::x ne $::tcl::abs} { + # Name changed during qualification + + set ::tcl::newCmds($::tcl::abs) 1 + unset ::tcl::newCmds($::tcl::x) + } + } } } - # Look through the packages that appeared, and if there is - # a version provided, then record it + # Look through the packages that appeared, and if there is a + # version provided, then record it foreach ::tcl::x [package names] { - if {[string compare [package provide $::tcl::x] ""] \ + if {[package provide $::tcl::x] ne "" && ![info exists ::tcl::packages($::tcl::x)]} { lappend ::tcl::newPkgs \ [list $::tcl::x [package provide $::tcl::x]] } } } - } msg] == 1} { + } on error msg { set what [$c eval set ::tcl::debug] if {$doVerbose} { tclLog "warning: error while $what $file: $msg" } - } else { + } on ok {} { + set what [$c eval set ::tcl::debug] + if {$doVerbose} { + tclLog "successful $what of $file" + } set type [$c eval set ::tcl::type] set cmds [lsort [$c eval array names ::tcl::newCmds]] set pkgs [$c eval set ::tcl::newPkgs] + if {$doVerbose} { + if {!$direct} { + tclLog "commands provided were $cmds" + } + tclLog "packages provided were $pkgs" + } if {[llength $pkgs] > 1} { tclLog "warning: \"$file\" provides more than one package ($pkgs)" } @@ -335,38 +379,45 @@ proc pkg_mkIndex {args} { if {$doVerbose} { tclLog "processed $file" } - interp delete $c } + interp delete $c } + append index "# Tcl package index file, version 1.1\n" + append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + foreach pkg [lsort [array names files]] { - append index "\npackage ifneeded $pkg " - if {$direct} { - set cmdList {} - foreach elem $files($pkg) { - set file [lindex $elem 0] - set type [lindex $elem 1] - lappend cmdList "\[list $type \[file join \$dir\ - [list $file]\]\]" - } - append index [join $cmdList "\\n"] - } else { - append index "\[list tclPkgSetup \$dir [lrange $pkg 0 0]\ - [lrange $pkg 1 1] [list $files($pkg)]\]" + set cmd {} + lassign $pkg name version + lappend cmd ::tcl::Pkg::Create -name $name -version $version + foreach spec [lsort -index 0 $files($pkg)] { + foreach {file type procs} $spec { + if {$direct} { + set procs {} + } + lappend cmd "-$type" [list $file $procs] + } } + append index "\n[eval $cmd]" } - set f [open pkgIndex.tcl w] + + set f [open [file join $dir pkgIndex.tcl] w] puts $f $index close $f - cd $oldDir } # tclPkgSetup -- -# This is a utility procedure use by pkgIndex.tcl files. It is invoked -# as part of a "package ifneeded" script. It calls "package provide" -# to indicate that a package is available, then sets entries in the -# auto_index array so that the package's files will be auto-loaded when -# the commands are used. +# This is a utility procedure use by pkgIndex.tcl files. It is invoked as +# part of a "package ifneeded" script. It calls "package provide" to indicate +# that a package is available, then sets entries in the auto_index array so +# that the package's files will be auto-loaded when the commands are used. # # Arguments: # dir - Directory containing all the files for this package. @@ -387,86 +438,310 @@ proc tclPkgSetup {dir pkg version files} { set f [lindex $fileInfo 0] set type [lindex $fileInfo 1] foreach cmd [lindex $fileInfo 2] { - if {[string equal $type "load"]} { + if {$type eq "load"} { set auto_index($cmd) [list load [file join $dir $f] $pkg] } else { set auto_index($cmd) [list source [file join $dir $f]] - } - } - } -} - -# tclMacPkgSearch -- -# The procedure is used on the Macintosh to search a given directory for files -# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the -# interpreter to setup the package database. - -proc tclMacPkgSearch {dir} { - foreach x [glob -nocomplain [file join $dir *.shlb]] { - if {[file isfile $x]} { - set res [resource open $x] - foreach y [resource list TEXT $res] { - if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex} } - catch {resource close $res} } } } # tclPkgUnknown -- -# This procedure provides the default for the "package unknown" function. -# It is invoked when a package that's needed can't be found. It scans -# the auto_path directories and their immediate children looking for -# pkgIndex.tcl files and sources any such files that are found to setup -# the package database. (On the Macintosh we also search for pkgIndex -# TEXT resources in all files.) +# This procedure provides the default for the "package unknown" function. It +# is invoked when a package that's needed can't be found. It scans the +# auto_path directories and their immediate children looking for pkgIndex.tcl +# files and sources any such files that are found to setup the package +# database. As it searches, it will recognize changes to the auto_path and +# scan any new directories. # # Arguments: # name - Name of desired package. Not used. # version - Version of desired package. Not used. # exact - Either "-exact" or omitted. Not used. -proc tclPkgUnknown {name version {exact {}}} { - global auto_path tcl_platform env +proc tclPkgUnknown {name args} { + global auto_path env if {![info exists auto_path]} { return } - for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { - # we can't use glob in safe interps, so enclose the following - # in a catch statement + # Cache the auto_path, because it may change while we run through the + # first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + + # Make sure we only scan each directory one time. + if {[info exists tclSeenPath($dir)]} { + set use_path [lrange $use_path 0 end-1] + continue + } + set tclSeenPath($dir) 1 + + # we can't use glob in safe interps, so enclose the following in a + # catch statement, where we get the pkgIndex files out of the + # subdirectories catch { - foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ - * pkgIndex.tcl]] { + foreach file [glob -directory $dir -join -nocomplain \ + * pkgIndex.tcl] { set dir [file dirname $file] - if {[file readable $file]} { - if {[catch {source $file} msg]} { + if {![info exists procdDirs($dir)]} { + try { + source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 } } } } - set dir [lindex $auto_path $i] - set file [file join $dir pkgIndex.tcl] - # safe interps usually don't have "file readable", nor stderr channel - if {[interp issafe] || [file readable $file]} { - if {[catch {source $file} msg] && ![interp issafe]} { - tclLog "error reading package index file $file: $msg" + set dir [lindex $use_path end] + if {![info exists procdDirs($dir)]} { + set file [file join $dir pkgIndex.tcl] + # safe interps usually don't have "file exists", + if {([interp issafe] || [file exists $file])} { + try { + source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $index now points to the first element of $auto_path that has + # changed, or the beginning if $auto_path has changed length Scan the + # new elements of $auto_path for directories to add to $use_path. + # Don't add directories we've already seen, or ones already on the + # $use_path. + foreach dir [lrange $auto_path $index end] { + if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { + lappend use_path $dir + } + } + set old_path $auto_path + } +} + +# tcl::MacOSXPkgUnknown -- +# This procedure extends the "package unknown" function for MacOSX. It scans +# the Resources/Scripts directories of the immediate children of the auto_path +# directories for pkgIndex files. +# +# Arguments: +# original - original [package unknown] procedure +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tcl::MacOSXPkgUnknown {original name args} { + # First do the cross-platform default search + uplevel 1 $original [linsert $args 0 $name] + + # Now do MacOSX specific searching + global auto_path + + if {![info exists auto_path]} { + return + } + # Cache the auto_path, because it may change while we run through the + # first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + + # Make sure we only scan each directory one time. + if {[info exists tclSeenPath($dir)]} { + set use_path [lrange $use_path 0 end-1] + continue + } + set tclSeenPath($dir) 1 + + # get the pkgIndex files out of the subdirectories + foreach file [glob -directory $dir -join -nocomplain \ + * Resources Scripts pkgIndex.tcl] { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $index now points to the first element of $auto_path that has + # changed, or the beginning if $auto_path has changed length Scan the + # new elements of $auto_path for directories to add to $use_path. + # Don't add directories we've already seen, or ones already on the + # $use_path. + foreach dir [lrange $auto_path $index end] { + if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { + lappend use_path $dir } } - # On the Macintosh we also look in the resource fork - # of shared libraries - # We can't use tclMacPkgSearch in safe interps because it uses glob - if {(![interp issafe]) && \ - [string equal $tcl_platform(platform) "macintosh"]} { - set dir [lindex $auto_path $i] - tclMacPkgSearch $dir - foreach x [glob -nocomplain [file join $dir *]] { - if {[file isdirectory $x]} { - set dir $x - tclMacPkgSearch $dir + set old_path $auto_path + } +} + +# ::tcl::Pkg::Create -- +# +# Given a package specification generate a "package ifneeded" statement +# for the package, suitable for inclusion in a pkgIndex.tcl file. +# +# Arguments: +# args arguments used by the Create function: +# -name packageName +# -version packageVersion +# -load {filename ?{procs}?} +# ... +# -source {filename ?{procs}?} +# ... +# +# Any number of -load and -source parameters may be +# specified, so long as there is at least one -load or +# -source parameter. If the procs component of a module +# specifier is left off, that module will be set up for +# direct loading; otherwise, it will be set up for lazy +# loading. If both -source and -load are specified, the +# -load'ed files will be loaded first, followed by the +# -source'd files. +# +# Results: +# An appropriate "package ifneeded" statement for the package. + +proc ::tcl::Pkg::Create {args} { + append err(usage) "[lindex [info level 0] 0] " + append err(usage) "-name packageName -version packageVersion" + append err(usage) "?-load {filename ?{procs}?}? ... " + append err(usage) "?-source {filename ?{procs}?}? ..." + + set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\"" + set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\"" + set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\"" + set err(noLoadOrSource) "at least one of -load and -source must be given" + + # process arguments + set len [llength $args] + if {$len < 6} { + error $err(wrongNumArgs) + } + + # Initialize parameters + array set opts {-name {} -version {} -source {} -load {}} + + # process parameters + for {set i 0} {$i < $len} {incr i} { + set flag [lindex $args $i] + incr i + switch -glob -- $flag { + "-name" - + "-version" { + if {$i >= $len} { + error [format $err(valueMissing) $flag] + } + set opts($flag) [lindex $args $i] + } + "-source" - + "-load" { + if {$i >= $len} { + error [format $err(valueMissing) $flag] } + lappend opts($flag) [lindex $args $i] + } + default { + error [format $err(unknownOpt) [lindex $args $i]] + } + } + } + + # Validate the parameters + if {![llength $opts(-name)]} { + error [format $err(valueMissing) "-name"] + } + if {![llength $opts(-version)]} { + error [format $err(valueMissing) "-version"] + } + + if {!([llength $opts(-source)] || [llength $opts(-load)])} { + error $err(noLoadOrSource) + } + + # OK, now everything is good. Generate the package ifneeded statment. + set cmdline "package ifneeded $opts(-name) $opts(-version) " + + set cmdList {} + set lazyFileList {} + + # Handle -load and -source specs + foreach key {load source} { + foreach filespec $opts(-$key) { + lassign $filespec filename proclist + + if { [llength $proclist] == 0 } { + set cmd "\[list $key \[file join \$dir [list $filename]\]\]" + lappend cmdList $cmd + } else { + lappend lazyFileList [list $filename $key $proclist] } } } + + if {[llength $lazyFileList]} { + lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\ + $opts(-version) [list $lazyFileList]\]" + } + append cmdline [join $cmdList "\\n"] + return $cmdline } + +interp alias {} ::pkg::create {} ::tcl::Pkg::Create |