diff options
Diffstat (limited to 'tcl8.6/library/package.tcl')
| -rw-r--r-- | tcl8.6/library/package.tcl | 747 |
1 files changed, 0 insertions, 747 deletions
diff --git a/tcl8.6/library/package.tcl b/tcl8.6/library/package.tcl deleted file mode 100644 index 44e3b28..0000000 --- a/tcl8.6/library/package.tcl +++ /dev/null @@ -1,747 +0,0 @@ -# package.tcl -- -# -# utility procs formerly in init.tcl which can be loaded on demand -# for package management. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1998 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -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. -# -# Arguments: -# fileName name of a file whose extension is compared -# ext (optional) The extension to compare against; you must -# provide the starting dot. -# Defaults to [info sharedlibextension] -# -# Results: -# Returns 1 if the extension matches, 0 otherwise - -proc tcl::Pkg::CompareExtension {fileName {ext {}}} { - global tcl_platform - if {$ext eq ""} {set ext [info sharedlibextension]} - if {$tcl_platform(platform) eq "windows"} { - return [string equal -nocase [file extension $fileName] $ext] - } else { - # 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. -# -# Arguments: -# -direct (optional) If this flag is present, the generated -# code in pkgMkIndex.tcl will cause the package to be -# loaded when "package require" is executed, rather -# than lazily when the first reference to an exported -# procedure in the package is made. -# -verbose (optional) Verbose output; the name of each file that -# was successfully rocessed is printed out. Additionally, -# if processing of a file failed a message is printed. -# -load pat (optional) Preload any packages whose names match -# the pattern. Used to handle DLLs that depend on -# other packages during their Init procedure. -# dir - Name of the directory in which to create the index. -# args - Any number of additional arguments, each giving -# a glob pattern that matches the names of one or -# more shared libraries or Tcl script files in -# dir. - -proc pkg_mkIndex {args} { - set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"} - - set argCount [llength $args] - if {$argCount < 1} { - return -code error "wrong # args: should be\n$usage" - } - - set more "" - set direct 1 - set doVerbose 0 - set loadPat "" - for {set idx 0} {$idx < $argCount} {incr idx} { - set flag [lindex $args $idx] - switch -glob -- $flag { - -- { - # done with the flags - incr idx - break - } - -verbose { - set doVerbose 1 - } - -lazy { - set direct 0 - append more " -lazy" - } - -direct { - append more " -direct" - } - -load { - incr idx - set loadPat [lindex $args $idx] - append more " -load $loadPat" - } - -* { - return -code error "unknown flag $flag: should be\n$usage" - } - default { - # done with the flags - break - } - } - } - - set dir [lindex $args $idx] - set patternList [lrange $args [expr {$idx + 1}] end] - if {![llength $patternList]} { - set patternList [list "*.tcl" "*[info sharedlibextension]"] - } - - 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. - - if {$file eq "pkgIndex.tcl"} { - continue - } - - 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 -nocase $loadPat [lindex $pkg 1]]} { - continue - } - if {$doVerbose} { - tclLog "package [lindex $pkg 1] matches '$loadPat'" - } - try { - load [lindex $pkg 0] [lindex $pkg 1] $c - } on error err { - if {$doVerbose} { - tclLog "warning: load [lindex $pkg 0]\ - [lindex $pkg 1]\nfailed with: $err" - } - } on ok {} { - if {$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 .] - } - } - - $c eval { - # 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 { - __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. - - proc unknown {args} {} - - # Stub out the auto_import mechanism - - 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. - - namespace eval ::tcl { - variable dir ;# Current directory being processed - variable file ;# Current file being processed - variable direct ;# -direct flag value - variable x ;# Loop variable - variable debug ;# For debugging - variable type ;# "load" or "source", for -direct - variable namespaces ;# Existing namespaces (e.g., ::tcl) - variable packages ;# Existing packages (e.g., Tcl) - variable origCmds ;# Existing commands - variable newCmds ;# Newly created commands - variable newPkgs {} ;# Newly created packages - } - } - - $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. - - foreach p {::tcl::Pkg::CompareExtension} { - $c eval [list namespace eval [namespace qualifiers $p] {}] - $c eval [list proc $p [info args $p] [info body $p]] - } - - 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. - - proc ::tcl::GetAllNamespaces {{root ::}} { - set list $root - foreach ns [namespace children $root] { - lappend list {*}[::tcl::GetAllNamespaces $ns] - } - return $list - } - - # init the list of existing namespaces, packages, commands - - foreach ::tcl::x [::tcl::GetAllNamespaces] { - set ::tcl::namespaces($::tcl::x) 1 - } - foreach ::tcl::x [package names] { - 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. - - 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::dir $::tcl::file] - set ::tcl::type load - } else { - set ::tcl::debug sourcing - source [file join $::tcl::dir $::tcl::file] - set ::tcl::type source - } - - # 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 - - foreach ::tcl::x [package names] { - if {[package provide $::tcl::x] ne "" - && ![info exists ::tcl::packages($::tcl::x)]} { - lappend ::tcl::newPkgs \ - [list $::tcl::x [package provide $::tcl::x]] - } - } - } - } on error msg { - set what [$c eval set ::tcl::debug] - if {$doVerbose} { - tclLog "warning: error while $what $file: $msg" - } - } 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)" - } - 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 {} - 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 [file join $dir pkgIndex.tcl] w] - puts $f $index - close $f -} - -# 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 {$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]] - } - } - } -} - -# 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. 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 args} { - global auto_path 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] - - # 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 -directory $dir -join -nocomplain \ - * 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 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 - } - } - 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 |