summaryrefslogtreecommitdiffstats
path: root/library/auto.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/auto.tcl')
-rw-r--r--library/auto.tcl288
1 files changed, 145 insertions, 143 deletions
diff --git a/library/auto.tcl b/library/auto.tcl
index b0fb61d..e86257e 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -1,22 +1,22 @@
# auto.tcl --
#
-# utility procs formerly in init.tcl dealing with auto execution
-# of commands and can be auto loaded themselves.
+# utility procs formerly in init.tcl dealing with auto execution of commands
+# and can be auto loaded themselves.
#
# 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.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# 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 commands that are listed in the auto-load index.
+# 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
+# commands that are listed in the auto-load index.
#
-# Arguments:
+# Arguments:
# None.
proc auto_reset {} {
@@ -24,25 +24,25 @@ proc auto_reset {} {
if {[array exists auto_index]} {
foreach cmdName [array names auto_index] {
set fqcn [namespace which $cmdName]
- if {$fqcn eq ""} {continue}
+ if {$fqcn eq ""} {
+ continue
+ }
rename $fqcn {}
}
}
unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
if {[catch {llength $auto_path}]} {
set auto_path [list [info library]]
- } else {
- if {[info library] ni $auto_path} {
- lappend auto_path [info library]
- }
+ } elseif {[info library] ni $auto_path} {
+ lappend auto_path [info library]
}
}
# 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.
+# 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")
@@ -64,24 +64,21 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {
-
# Do the canonical search
- # 1. From an environment variable, if it exists.
- # Placing this first gives the end-user ultimate control
- # to work-around any bugs, or to customize.
+ # 1. From an environment variable, if it exists. Placing this first
+ # gives the end-user ultimate control to work-around any bugs, or
+ # to customize.
if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}
- # 2. In the package script directory registered within
- # the configuration of the package itself.
+ # 2. In the package script directory registered within the
+ # configuration of the package itself.
- if {[catch {
- ::${basename}::pkgconfig get scriptdir,runtime
- } value] == 0} {
- lappend dirs $value
+ catch {
+ lappend dirs [::${basename}::pkgconfig get scriptdir,runtime]
}
# 3. Relative to auto_path directories. This checks relative to the
@@ -101,8 +98,8 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
# ../library (From unix directory in build hierarchy)
#
- # Remaining locations are out of date (when relevant, they ought
- # to be covered by the $::auto_path seach above) and disabled.
+ # Remaining locations are out of date (when relevant, they ought to be
+ # covered by the $::auto_path seach above) and disabled.
#
# ../../library (From unix/arch directory in build hierarchy)
# ../../foo1.0.1/library
@@ -125,17 +122,19 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# uniquify $dirs in order
array set seen {}
foreach i $dirs {
- # Take note that the [file normalize] below has been noted to
- # cause difficulties for the freewrap utility. See Bug 1072136.
- # Until freewrap resolves the matter, one might work around the
- # problem by disabling that branch.
+ # Take note that the [file normalize] below has been noted to cause
+ # difficulties for the freewrap utility. See Bug 1072136. Until
+ # freewrap resolves the matter, one might work around the problem by
+ # disabling that branch.
if {[interp issafe]} {
set norm $i
} else {
set norm [file normalize $i]
}
- if {[info exists seen($norm)]} { continue }
- set seen($norm) ""
+ if {[info exists seen($norm)]} {
+ continue
+ }
+ set seen($norm) {}
lappend uniqdirs $i
}
set dirs $uniqdirs
@@ -143,16 +142,15 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
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
+ # 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 opts]} {
return
- } else {
- append errors "$file: $msg\n"
- append errors [dict get $opts -errorinfo]\n
}
+ append errors "$file: $msg\n"
+ append errors [dict get $opts -errorinfo]\n
}
}
unset -nocomplain the_library
@@ -167,28 +165,28 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# ----------------------------------------------------------------------
# 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.
+# 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 {[interp issafe]} {
return ;# Stop sourcing the file here
}
# 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.
+# 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:
+# 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.
+
+# 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} {
if {[interp issafe]} {
@@ -197,7 +195,6 @@ proc auto_mkindex {dir args} {
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"
@@ -206,18 +203,18 @@ proc auto_mkindex {dir args} {
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 {[llength $args] == 0} {
+ if {![llength $args]} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [glob -- {*}$args] {
- if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
- append index $msg
- } else {
- cd $oldDir
+ try {
+ append index [auto_mkindex_parser::mkindex $file]
+ } on error {msg opts} {
+ cd $oldDir
return -options $opts $msg
- }
+ }
}
auto_mkindex_parser::cleanup
@@ -227,8 +224,8 @@ proc auto_mkindex {dir args} {
cd $oldDir
}
-# Original version of auto_mkindex that just searches the source
-# code for "proc" at the beginning of the line.
+# 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} {
set oldDir [pwd]
@@ -241,7 +238,7 @@ proc auto_mkindex_old {dir args} {
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 {[llength $args] == 0} {
+ if {![llength $args]} {
set args *.tcl
}
foreach file [glob -- {*}$args] {
@@ -279,9 +276,9 @@ proc auto_mkindex_old {dir args} {
}
# 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.
+# 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
@@ -306,7 +303,14 @@ namespace eval auto_mkindex_parser {
$parser hide namespace
$parser hide eval
$parser hide puts
- $parser invokehidden namespace delete ::
+ foreach ns [$parser invokehidden namespace children ::] {
+ # MUST NOT DELETE "::tcl" OR BAD THINGS HAPPEN!
+ if {$ns eq "::tcl"} continue
+ $parser invokehidden namespace delete $ns
+ }
+ foreach cmd [$parser invokehidden info commands ::*] {
+ $parser invokehidden rename $cmd {}
+ }
$parser invokehidden proc unknown {args} {}
# We'll need access to the "namespace" command within the
@@ -333,12 +337,12 @@ namespace eval auto_mkindex_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.
+# 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:
+# Arguments:
# file Name of Tcl source file to be indexed.
proc auto_mkindex_parser::mkindex {file} {
@@ -354,14 +358,13 @@ proc auto_mkindex_parser::mkindex {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.
- # To avoid this, we replace all $ with \0 (literally, the null char)
- # later, when getting proc names we will have to reverse this replacement,
- # in case there were any $ in the proc name. This will cause a problem
- # if somebody actually tries to have a \0 in their proc name. Too bad
- # for them.
+ # 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. To avoid this, we replace all $ with
+ # \0 (literally, the null char) later, when getting proc names we will
+ # have to reverse this replacement, in case there were any $ in the proc
+ # name. This will cause a problem if somebody actually tries to have a \0
+ # in their proc name. Too bad for them.
set contents [string map [list \$ \0] $contents]
set index ""
@@ -378,10 +381,10 @@ proc auto_mkindex_parser::mkindex {file} {
# 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
+# 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
@@ -391,30 +394,30 @@ proc auto_mkindex_parser::hook {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.
+# 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.
+ # 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.
+# 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.
+# 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.
@@ -427,8 +430,8 @@ proc auto_mkindex_parser::command {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.
+# 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.
@@ -447,25 +450,23 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
}
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.
+ # 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 {[string match *::* $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
-
- # 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:
+
+ # 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
+ # 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
+ # A gold star to someone that can make test autoMkindex-3.3 work
+ # properly
set alias [namespace tail $fakeName]
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
@@ -477,15 +478,14 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
}
# 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.
+#
+# 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.
@@ -508,8 +508,8 @@ proc auto_mkindex_parser::fullname {name} {
set name "::$name"
}
- # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
- # that replacement.
+ # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that
+ # replacement.
return [string map [list \0 \$] $name]
}
@@ -517,8 +517,8 @@ if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
-# Register all of the procedures for the auto_mkindex parser that
-# will build the "tclIndex" file.
+# 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.
@@ -528,24 +528,27 @@ auto_mkindex_parser::command proc {name args} {
variable scriptFile
# Do some fancy reformatting on the "source" call to handle platform
# differences with respect to pathnames. Use format just so that the
- # command is a little easier to read (otherwise it'd be full of
+ # command is a little easier to read (otherwise it'd be full of
# backslashed dollar signs, etc.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $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
+# 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}]} {
+ try {
+ package require tbcload
+ } on error {} {
+ # OK, don't have it so do nothing
+ } on ok {} {
if {[namespace which -command tbcload::bcproc] eq ""} {
auto_load tbcload::bcproc
}
@@ -553,7 +556,7 @@ auto_mkindex_parser::hook {
# AUTO MKINDEX: tbcload::bcproc name arglist body
# Adds an entry to the auto index list for the given pre-compiled
- # procedure name.
+ # procedure name.
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
variable index
@@ -569,16 +572,15 @@ auto_mkindex_parser::hook {
}
# AUTO MKINDEX: namespace eval name command ?arg arg...?
-# Adds the namespace name onto the context stack and evaluates the
-# associated body of commands.
+# 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.
+# 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 {