summaryrefslogtreecommitdiffstats
path: root/library/init.tcl
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /library/init.tcl
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'library/init.tcl')
-rw-r--r--library/init.tcl1015
1 files changed, 7 insertions, 1008 deletions
diff --git a/library/init.tcl b/library/init.tcl
index c592e01..acd403d 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.28 1999/03/31 22:37:03 welch Exp $
+# RCS: @(#) $Id: init.tcl,v 1.29 1999/04/16 00:46:56 stanton Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -16,7 +16,7 @@
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
-package require -exact Tcl 8.0
+package require -exact Tcl 8.1
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
@@ -59,8 +59,8 @@ if {[info exist tcl_pkgPath]} {
if {[info exists __dir]} {
unset __dir
}
-
-# Windows specific initialization to handle case isses with envars
+
+# Windows specific end of initialization
if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
namespace eval tcl {
@@ -373,7 +373,7 @@ proc auto_load_index {} {
# auto_qualify --
#
-# compute a fully qualified names list for use in the auto_index array.
+# Compute a fully qualified names list for use in the auto_index array.
# For historical reasons, commands in the global namespace do not have leading
# :: in the index key. The list has two elements when the command name is
# relative (no leading ::) and the namespace is not the global one. Otherwise
@@ -433,7 +433,7 @@ proc auto_qualify {cmd namespace} {
# auto_import --
#
-# invoked during "namespace import" to make see if the imported commands
+# Invoked during "namespace import" to make see if the imported commands
# reside in an autoloaded library. If so, the commands are loaded so
# that they will be available for the import links. If not, then this
# procedure does nothing.
@@ -459,8 +459,6 @@ proc auto_import {pattern} {
}
}
-if {[string compare $tcl_platform(platform) windows] == 0} {
-
# auto_execok --
#
# Returns string that indicates name of program to execute if
@@ -472,6 +470,7 @@ if {[string compare $tcl_platform(platform) windows] == 0} {
# Arguments:
# name - Name of a command.
+if {[string compare $tcl_platform(platform) windows] == 0} {
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
@@ -532,17 +531,6 @@ proc auto_execok name {
}
} else {
-
-# auto_execok --
-#
-# Returns string that indicates name of program to execute if
-# name corresponds to an executable in the path. Builds an associative
-# array auto_execs that caches information about previous checks,
-# for speed.
-#
-# Arguments:
-# name - Name of a command.
-
# Unix version.
#
proc auto_execok name {
@@ -572,992 +560,3 @@ proc auto_execok name {
}
}
-# OPTIONAL SUPPORT PROCEDURES
-# In Tcl 8.1 all the code below here has been moved to other files to
-# reduce the size of init.tcl
-
-# auto_reset --
-#
-# Destroy all cached information for auto-loading and auto-execution,
-# so that the information gets recomputed the next time it's needed.
-# Also delete any procedures that are listed in the auto-load index
-# except those defined in this file.
-#
-# Arguments:
-# None.
-
-proc auto_reset {} {
- global auto_execs auto_index auto_oldpath
- foreach p [info procs] {
- if {[info exists auto_index($p)] && ![string match auto_* $p]
- && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
- tcl_findLibrary pkg_compareExtension
- tclMacPkgSearch tclPkgUnknown} $p] < 0)} {
- rename $p {}
- }
- }
- catch {unset auto_execs}
- catch {unset auto_index}
- catch {unset auto_oldpath}
-}
-
-# tcl_findLibrary --
-#
-# This is a utility for extensions that searches for a library directory
-# using a canonical searching algorithm. A side effect is to source
-# the initialization script and set a global library variable.
-#
-# Arguments:
-# basename Prefix of the directory name, (e.g., "tk")
-# version Version number of the package, (e.g., "8.0")
-# patch Patchlevel of the package, (e.g., "8.0.3")
-# initScript Initialization script to source (e.g., tk.tcl)
-# enVarName environment variable to honor (e.g., TK_LIBRARY)
-# varName Global variable to set when done (e.g., tk_library)
-
-proc tcl_findLibrary {basename version patch initScript enVarName varName} {
- upvar #0 $varName the_library
- global env errorInfo
-
- set dirs {}
- set errors {}
-
- # The C application may have hardwired a path, which we honor
-
- if {[info exist the_library] && [string compare $the_library {}]} {
- lappend dirs $the_library
- } else {
-
- # Do the canonical search
-
- # 1. From an environment variable, if it exists
-
- if {[info exists env($enVarName)]} {
- lappend dirs $env($enVarName)
- }
-
- # 2. Relative to the Tcl library
-
- lappend dirs [file join [file dirname [info library]] \
- $basename$version]
-
- # 3. Various locations relative to the executable
- # ../lib/foo1.0 (From bin directory in install hierarchy)
- # ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
- # ../library (From unix directory in build hierarchy)
- # ../../library (From unix/arch directory in build hierarchy)
- # ../../foo1.0b1/library (From unix directory in parallel build hierarchy)
- # ../../../foo1.0b1/library (From unix/arch directory in parallel build hierarchy)
-
- set parentDir [file dirname [file dirname [info nameofexecutable]]]
- set grandParentDir [file dirname $parentDir]
- lappend dirs [file join $parentDir lib $basename$version]
- lappend dirs [file join $grandParentDir lib $basename$version]
- lappend dirs [file join $parentDir library]
- lappend dirs [file join $grandParentDir library]
- if {![regexp {.*[ab][0-9]*} $patch ver]} {
- set ver $version
- }
- lappend dirs [file join $grandParentDir $basename$ver library]
- lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]
- }
- foreach i $dirs {
- set the_library $i
- set file [file join $i $initScript]
-
- # source everything when in a safe interpreter because
- # we have a source command, but no file exists command
-
- if {[interp issafe] || [file exists $file]} {
- if {![catch {uplevel #0 [list source $file]} msg]} {
- return
- } else {
- append errors "$file: $msg\n$errorInfo\n"
- }
- }
- }
- set msg "Can't find a usable $initScript in the following directories: \n"
- append msg " $dirs\n\n"
- append msg "$errors\n\n"
- append msg "This probably means that $basename wasn't installed properly.\n"
- error $msg
-}
-
-
-# ----------------------------------------------------------------------
-# auto_mkindex
-# ----------------------------------------------------------------------
-# The following procedures are used to generate the tclIndex file
-# from Tcl source files. They use a special safe interpreter to
-# parse Tcl source files, writing out index entries as "proc"
-# commands are encountered. This implementation won't work in a
-# safe interpreter, since a safe interpreter can't create the
-# special parser and mess with its commands. If this is a safe
-# interpreter, we simply clip these procs out.
-
-if {! [interp issafe]} {
-
- # auto_mkindex --
- # Regenerate a tclIndex file from Tcl source files. Takes as argument
- # the name of the directory in which the tclIndex file is to be placed,
- # followed by any number of glob patterns to use in that directory to
- # locate all of the relevant files.
- #
- # Arguments:
- # dir - Name of the directory in which to create an index.
- # args - Any number of additional arguments giving the
- # names of files within dir. If no additional
- # are given auto_mkindex will look for *.tcl.
-
- proc auto_mkindex {dir args} {
- global errorCode errorInfo
-
- set oldDir [pwd]
- cd $dir
- set dir [pwd]
-
- append index "# Tcl autoload index file, version 2.0\n"
- append index "# This file is generated by the \"auto_mkindex\" command\n"
- append index "# and sourced to set up indexing information for one or\n"
- append index "# more commands. Typically each line is a command that\n"
- append index "# sets an element in the auto_index array, where the\n"
- append index "# element name is the name of a command and the value is\n"
- append index "# a script that loads the command.\n\n"
- if {$args == ""} {
- set args *.tcl
- }
-
- auto_mkindex_parser::init
- foreach file [eval glob $args] {
- if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
- append index $msg
- } else {
- set code $errorCode
- set info $errorInfo
- cd $oldDir
- error $msg $info $code
- }
- }
- auto_mkindex_parser::cleanup
-
- set fid [open "tclIndex" w]
- puts $fid $index nonewline
- close $fid
- cd $oldDir
- }
-
- # Original version of auto_mkindex that just searches the source
- # code for "proc" at the beginning of the line.
-
- proc auto_mkindex_old {dir args} {
- global errorCode errorInfo
- set oldDir [pwd]
- cd $dir
- set dir [pwd]
- append index "# Tcl autoload index file, version 2.0\n"
- append index "# This file is generated by the \"auto_mkindex\" command\n"
- append index "# and sourced to set up indexing information for one or\n"
- append index "# more commands. Typically each line is a command that\n"
- append index "# sets an element in the auto_index array, where the\n"
- append index "# element name is the name of a command and the value is\n"
- append index "# a script that loads the command.\n\n"
- if {$args == ""} {
- set args *.tcl
- }
- foreach file [eval glob $args] {
- set f ""
- set error [catch {
- set f [open $file]
- while {[gets $f line] >= 0} {
- if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
- set procName [lindex [auto_qualify $procName "::"] 0]
- append index "set [list auto_index($procName)]"
- append index " \[list source \[file join \$dir [list $file]\]\]\n"
- }
- }
- close $f
- } msg]
- if {$error} {
- set code $errorCode
- set info $errorInfo
- catch {close $f}
- cd $oldDir
- error $msg $info $code
- }
- }
- set f ""
- set error [catch {
- set f [open tclIndex w]
- puts $f $index nonewline
- close $f
- cd $oldDir
- } msg]
- if {$error} {
- set code $errorCode
- set info $errorInfo
- catch {close $f}
- cd $oldDir
- error $msg $info $code
- }
- }
-
- # Create a safe interpreter that can be used to parse Tcl source files
- # generate a tclIndex file for autoloading. This interp contains
- # commands for things that need index entries. Each time a command
- # is executed, it writes an entry out to the index file.
-
- namespace eval auto_mkindex_parser {
- variable parser "" ;# parser used to build index
- variable index "" ;# maintains index as it is built
- variable scriptFile "" ;# name of file being processed
- variable contextStack "" ;# stack of namespace scopes
- variable imports "" ;# keeps track of all imported cmds
- variable initCommands "" ;# list of commands that create aliases
-
- proc init {} {
- variable parser
- variable initCommands
-
- if {![interp issafe]} {
- set parser [interp create -safe]
- $parser hide info
- $parser hide rename
- $parser hide proc
- $parser hide namespace
- $parser hide eval
- $parser hide puts
- $parser invokehidden namespace delete ::
- $parser invokehidden proc unknown {args} {}
-
- # We'll need access to the "namespace" command within the
- # interp. Put it back, but move it out of the way.
-
- $parser expose namespace
- $parser invokehidden rename namespace _%@namespace
- $parser expose eval
- $parser invokehidden rename eval _%@eval
-
- # Install all the registered psuedo-command implementations
-
- foreach cmd $initCommands {
- eval $cmd
- }
- }
- }
- proc cleanup {} {
- variable parser
- interp delete $parser
- unset parser
- }
- }
-
- # auto_mkindex_parser::mkindex --
- #
- # Used by the "auto_mkindex" command to create a "tclIndex" file for
- # the given Tcl source file. Executes the commands in the file, and
- # handles things like the "proc" command by adding an entry for the
- # index file. Returns a string that represents the index file.
- #
- # Arguments:
- # file Name of Tcl source file to be indexed.
-
- proc auto_mkindex_parser::mkindex {file} {
- variable parser
- variable index
- variable scriptFile
- variable contextStack
- variable imports
-
- set scriptFile $file
-
- set fid [open $file]
- set contents [read $fid]
- close $fid
-
- # There is one problem with sourcing files into the safe
- # interpreter: references like "$x" will fail since code is not
- # really being executed and variables do not really exist.
- # Be careful to escape all naked "$" before evaluating.
-
- regsub -all {([^\$])\$([^\$])} $contents {\1\\$\2} contents
-
- set index ""
- set contextStack ""
- set imports ""
-
- $parser eval $contents
-
- foreach name $imports {
- catch {$parser eval [list _%@namespace forget $name]}
- }
- return $index
- }
-
- # auto_mkindex_parser::hook command
- #
- # Registers a Tcl command to evaluate when initializing the
- # slave interpreter used by the mkindex parser.
- # The command is evaluated in the master interpreter, and can
- # use the variable auto_mkindex_parser::parser to get to the slave
-
- proc auto_mkindex_parser::hook {cmd} {
- variable initCommands
-
- lappend initCommands $cmd
- }
-
- # auto_mkindex_parser::slavehook command
- #
- # Registers a Tcl command to evaluate when initializing the
- # slave interpreter used by the mkindex parser.
- # The command is evaluated in the slave interpreter.
-
- proc auto_mkindex_parser::slavehook {cmd} {
- variable initCommands
-
- # The $parser variable is defined to be the name of the
- # slave interpreter when this command is used later.
-
- lappend initCommands "\$parser eval [list $cmd]"
- }
-
- # auto_mkindex_parser::command --
- #
- # Registers a new command with the "auto_mkindex_parser" interpreter
- # that parses Tcl files. These commands are fake versions of things
- # like the "proc" command. When you execute them, they simply write
- # out an entry to a "tclIndex" file for auto-loading.
- #
- # This procedure allows extensions to register their own commands
- # with the auto_mkindex facility. For example, a package like
- # [incr Tcl] might register a "class" command so that class definitions
- # could be added to a "tclIndex" file for auto-loading.
- #
- # Arguments:
- # name Name of command recognized in Tcl files.
- # arglist Argument list for command.
- # body Implementation of command to handle indexing.
-
- proc auto_mkindex_parser::command {name arglist body} {
- hook [list auto_mkindex_parser::commandInit $name $arglist $body]
- }
-
- # auto_mkindex_parser::commandInit --
- #
- # This does the actual work set up by auto_mkindex_parser::command
- # This is called when the interpreter used by the parser is created.
- #
- # Arguments:
- # name Name of command recognized in Tcl files.
- # arglist Argument list for command.
- # body Implementation of command to handle indexing.
-
- proc auto_mkindex_parser::commandInit {name arglist body} {
- variable parser
-
- set ns [namespace qualifiers $name]
- set tail [namespace tail $name]
- if {$ns == ""} {
- set fakeName "[namespace current]::_%@fake_$tail"
- } else {
- set fakeName "_%@fake_$name"
- regsub -all {::} $fakeName "_" fakeName
- set fakeName "[namespace current]::$fakeName"
- }
- proc $fakeName $arglist $body
-
- # YUK! Tcl won't let us alias fully qualified command names,
- # so we can't handle names like "::itcl::class". Instead,
- # we have to build procs with the fully qualified names, and
- # have the procs point to the aliases.
-
- if {[regexp {::} $name]} {
- set exportCmd [list _%@namespace export [namespace tail $name]]
- $parser eval [list _%@namespace eval $ns $exportCmd]
- set alias [namespace tail $fakeName]
-
- # The following proc definition does not work if you
- # want to tolerate space or something else diabolical
- # in the procedure name, (i.e., space in $alias)
- # The following does not work:
- # "_%@eval {$alias} \$args"
- # because $alias gets concat'ed to $args.
- # The following does not work because $cmd is somehow undefined
- # "set cmd {$alias} \; _%@eval {\$cmd} \$args"
- # A gold star to someone that can make test
- # autoMkindex-3.3 work properly
-
- $parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
- $parser alias $alias $fakeName
- } else {
- $parser alias $name $fakeName
- }
- return
- }
-
- # auto_mkindex_parser::fullname --
- # Used by commands like "proc" within the auto_mkindex parser.
- # Returns the qualified namespace name for the "name" argument.
- # If the "name" does not start with "::", elements are added from
- # the current namespace stack to produce a qualified name. Then,
- # the name is examined to see whether or not it should really be
- # qualified. If the name has more than the leading "::", it is
- # returned as a fully qualified name. Otherwise, it is returned
- # as a simple name. That way, the Tcl autoloader will recognize
- # it properly.
- #
- # Arguments:
- # name - Name that is being added to index.
-
- proc auto_mkindex_parser::fullname {name} {
- variable contextStack
-
- if {![string match ::* $name]} {
- foreach ns $contextStack {
- set name "${ns}::$name"
- if {[string match ::* $name]} {
- break
- }
- }
- }
-
- if {[namespace qualifiers $name] == ""} {
- return [namespace tail $name]
- } elseif {![string match ::* $name]} {
- return "::$name"
- }
- return $name
- }
-
- # Register all of the procedures for the auto_mkindex parser that
- # will build the "tclIndex" file.
-
- # AUTO MKINDEX: proc name arglist body
- # Adds an entry to the auto index list for the given procedure name.
-
- auto_mkindex_parser::command proc {name args} {
- variable index
- variable scriptFile
- append index [list set auto_index([fullname $name])] \
- " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
- }
-
- # Conditionally add support for Tcl byte code files. There are some
- # tricky details here. First, we need to get the tbcload library
- # initialized in the current interpreter. We cannot load tbcload into the
- # slave until we have done so because it needs access to the tcl_patchLevel
- # variable. Second, because the package index file may defer loading the
- # library until we invoke a command, we need to explicitly invoke auto_load
- # to force it to be loaded. This should be a noop if the package has
- # already been loaded
-
- auto_mkindex_parser::hook {
- if {![catch {package require tbcload}]} {
- if {[info commands tbcload::bcproc] == ""} {
- auto_load tbcload::bcproc
- }
- load {} tbcload $auto_mkindex_parser::parser
-
- # AUTO MKINDEX: tbcload::bcproc name arglist body
- # Adds an entry to the auto index list for the given pre-compiled
- # procedure name.
-
- auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
- variable index
- variable scriptFile
- append index [list set auto_index([fullname $name])] \
- " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
- }
- }
- }
-
- # AUTO MKINDEX: namespace eval name command ?arg arg...?
- # Adds the namespace name onto the context stack and evaluates the
- # associated body of commands.
- #
- # AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
- # Performs the "import" action in the parser interpreter. This is
- # important for any commands contained in a namespace that affect
- # the index. For example, a script may say "itcl::class ...",
- # or it may import "itcl::*" and then say "class ...". This
- # procedure does the import operation, but keeps track of imported
- # patterns so we can remove the imports later.
-
- auto_mkindex_parser::command namespace {op args} {
- switch -- $op {
- eval {
- variable parser
- variable contextStack
-
- set name [lindex $args 0]
- set args [lrange $args 1 end]
-
- set contextStack [linsert $contextStack 0 $name]
- $parser eval [list _%@namespace eval $name] $args
- set contextStack [lrange $contextStack 1 end]
- }
- import {
- variable parser
- variable imports
- foreach pattern $args {
- if {$pattern != "-force"} {
- lappend imports $pattern
- }
- }
- catch {$parser eval [list _%@namespace import] $args}
- }
- }
- }
-
-# Close of the if ![interp issafe] block
-}
-
-# 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.
-#
-# 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 pkg_compareExtension { fileName {ext {}} } {
- global tcl_platform
- if {[string length $ext] == 0} {
- set ext [info sharedlibextension]
- }
- if {[string compare $tcl_platform(platform) "windows"] == 0} {
- return [expr {[string compare \
- [string tolower [file extension $fileName]] \
- [string tolower $ext]] == 0}]
- } else {
- return [expr {[string compare [file extension $fileName] $ext] == 0}]
- }
-}
-
-# 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} {
- global errorCode errorInfo
- set usage {"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?"};
-
- set argCount [llength $args]
- if {$argCount < 1} {
- return -code error "wrong # args: should be\n$usage"
- }
-
- set more ""
- set direct 0
- 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
- }
- -direct {
- set direct 1
- 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] == 0} {
- 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
- }
- 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 {[string compare $file "pkgIndex.tcl"] == 0} {
- 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.
-
- foreach pkg [info loaded] {
- if {! [string match $loadPat [lindex $pkg 1]]} {
- continue
- }
- if {[lindex $pkg 1] == "Tk"} {
- $c eval {set argv {-geometry +0+0}}
- }
- if {[catch {
- load [lindex $pkg 0] [lindex $pkg 1] $c
- } err]} {
- if {$doVerbose} {
- tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
- }
- } else {
- if {$doVerbose} {
- tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
- }
- }
- }
- cd $dir
-
- $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 { eval __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 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::file $file]
- $c eval [list set ::tcl::direct $direct]
- if {[catch {
- $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] {
- eval lappend list [::tcl::GetAllNamespaces $ns]
- }
- return $list
- }
-
- # initialize the list of existing namespaces, packages, commands
-
- foreach ::tcl::x [::tcl::GetAllNamespaces] {
- set ::tcl::namespaces($::tcl::x) 1
- }
- foreach ::tcl::x [package names] {
- 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 {[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]
- set ::tcl::type load
- } else {
- set ::tcl::debug sourcing
- source $::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] != 0} {
- # 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 {([string compare [package provide $::tcl::x] ""] != 0) \
- && ![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 type [$c eval set ::tcl::type]
- set cmds [lsort [$c eval array names ::tcl::newCmds]]
- set pkgs [$c eval set ::tcl::newPkgs]
- 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
- }
-
- 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 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 {$type == "load"} {
- set auto_index($cmd) [list load [file join $dir $f] $pkg]
- } else {
- set auto_index($cmd) [list $type [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 {$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.)
-#
-# 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
- }
- 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
- catch {
- foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
- * pkgIndex.tcl]] {
- set dir [file dirname $file]
- if {[catch {source $file} msg]} {
- tclLog "error reading package index file $file: $msg"
- }
- }
- }
- 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"
- }
- }
- # 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]) && ($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
- }
- }
- }
- }
-}