figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

package.tcl (22959B)


      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