package.tcl

基于语义本体的单词查询系统

				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

		foreach ::tcl::x [package names] {
		    if {[string compare [package provide $::tcl::x] ""] \
			    && ![info exists ::tcl::packages($::tcl::x)]} {
			lappend ::tcl::newPkgs \
			    [list $::tcl::x [package provide $::tcl::x]]
		    }
		}
	    }
	} msg] == 1} {
	    set what [$c eval set ::tcl::debug]
	    if {$doVerbose} {
		tclLog "warning: error while $what $file: $msg"
	    }
	} else {
	    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} {
		tclLog "commands provided were $cmds"
		tclLog "packages provided were $pkgs"
	    }
	    if {[llength $pkgs] > 1} {
		tclLog "warning: \"$file\" provides more than one package ($pkgs)"
	    }
	    foreach pkg $pkgs {
		# cmds is empty/not used in the direct case
		lappend files($pkg) [list $file $type $cmds]
	    }

	    if {$doVerbose} {
		tclLog "processed $file"
	    }
	    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]] {
	set cmd {}
	foreach {name version} $pkg {
	    break
	}
	lappend cmd ::pkg::create -name $name -version $version
	foreach spec $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]
    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.
#
# Arguments:
# dir -			Directory containing all the files for this package.
# pkg -			Name of the package (no version number).
# version -		Version number for the package, such as 2.1.3.
# files -		List of files that constitute the package.  Each
#			element is a sub-list with three elements.  The first
#			is the name of a file relative to $dir, the second is
#			"load" or "source", indicating whether the file is a
#			loadable binary or a script to source, and the third
#			is a list of commands defined by this file.

proc tclPkgSetup {dir pkg version files} {
    global auto_index

    package provide $pkg $version
    foreach fileInfo $files {
	set f [lindex $fileInfo 0]
	set type [lindex $fileInfo 1]
	foreach cmd [lindex $fileInfo 2] {
	    if {[string equal $type "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 -directory $dir -nocomplain *.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.)  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

    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]
	# 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 -directory $dir -join -nocomplain \
		    * pkgIndex.tcl] {
		set dir [file dirname $file]
		if {[file readable $file] && ![info exists procdDirs($dir)]} {
		    if {[catch {source $file} msg]} {
			tclLog "error reading package index file $file: $msg"
		    } else {
			set procdDirs($dir) 1
		    }
		}
	    }
	}
	set dir [lindex $use_path end]
	set file [file join $dir pkgIndex.tcl]
	# safe interps usually don't have "file readable", nor stderr channel
	if {([interp issafe] || [file readable $file]) && \
		![info exists procdDirs($dir)]} {
	    if {[catch {source $file} msg] && ![interp issafe]}  {
		tclLog "error reading package index file $file: $msg"
	    } else {
		set procdDirs($dir) 1
	    }
	}
	# 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 $use_path end]
	    if {![info exists procdDirs($dir)]} {
		tclMacPkgSearch $dir
		set procdDirs($dir) 1
	    }
	    foreach x [glob -directory $dir -nocomplain *] {
		if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
		    set dir $x
		    tclMacPkgSearch $dir
		    set procdDirs($dir) 1
		}
	    }
	}
	set use_path [lrange $use_path 0 end-1]
	if {[string compare $old_path $auto_path]} {
	    foreach dir $auto_path {
		lappend use_path $dir
	    }
	    set old_path $auto_path
	}
    }
}

# ::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 ::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
    set opts(-name)		{}
    set opts(-version)		{}
    set opts(-source)		{}
    set opts(-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)] == 0 } {
	error [format $err(valueMissing) "-name"]
    }
    if { [llength $opts(-version)] == 0 } {
	error [format $err(valueMissing) "-version"]
    }
    
    if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
	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) {
	    foreach {filename proclist} {{} {}} {
		break
	    }
	    foreach {filename proclist} $filespec {
		break
	    }
	    
	    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] > 0 } {
	lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
		$opts(-version) [list $lazyFileList]\]"
    }
    append cmdline [join $cmdList "\\n"]
    return $cmdline
}