summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/auto.tcl262
-rw-r--r--library/package.tcl252
-rw-r--r--library/safe.tcl452
-rw-r--r--library/tm.tcl214
4 files changed, 586 insertions, 594 deletions
diff --git a/library/auto.tcl b/library/auto.tcl
index 881e6b9..7d4c340 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.
#
-# RCS: @(#) $Id: auto.tcl,v 1.28 2006/11/03 00:34:52 hobbs Exp $
+# RCS: @(#) $Id: auto.tcl,v 1.29 2009/07/26 11:40:23 dkf Exp $
#
# 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:
# None.
@@ -32,18 +32,16 @@ proc auto_reset {} {
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")
@@ -68,21 +66,25 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# 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 {
+ try {
::${basename}::pkgconfig get scriptdir,runtime
- } value] == 0} {
+ } on ok value {
lappend dirs $value
+ } on error {msg opts} {
+ if {![string match "invalid command name *" $msg]} {
+ return -options $opts $msg
+ }
}
# 3. Relative to auto_path directories. This checks relative to the
@@ -90,8 +92,10 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# auto_path that is not relative to the core library or binary paths.
foreach d $::auto_path {
lappend dirs [file join $d $basename$version]
- if {$::tcl_platform(platform) eq "unix"
- && $::tcl_platform(os) eq "Darwin"} {
+ if {
+ $::tcl_platform(platform) eq "unix"
+ && $::tcl_platform(os) eq "Darwin"
+ } then {
# 4. On MacOSX, check the Resources/Scripts subdir too
lappend dirs [file join $d $basename$version Resources Scripts]
}
@@ -102,8 +106,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
@@ -126,10 +130,10 @@ 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 {
@@ -144,16 +148,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
@@ -168,28 +171,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:
# 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]} {
@@ -198,7 +201,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"
@@ -213,12 +215,12 @@ proc auto_mkindex {dir args} {
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
@@ -228,8 +230,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]
@@ -280,9 +282,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
@@ -334,10 +336,10 @@ 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:
# file Name of Tcl source file to be indexed.
@@ -355,14 +357,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 ""
@@ -379,10 +380,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
@@ -392,30 +393,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.
@@ -428,8 +429,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.
@@ -448,25 +449,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"
@@ -478,15 +477,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.
@@ -509,8 +507,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]
}
@@ -518,8 +516,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.
@@ -536,17 +534,20 @@ auto_mkindex_parser::command proc {name args} {
[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
}
@@ -570,16 +571,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 {
diff --git a/library/package.tcl b/library/package.tcl
index 56dccd0..d8729b2 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -3,7 +3,7 @@
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
-# RCS: @(#) $Id: package.tcl,v 1.36 2008/07/03 17:28:46 dgp Exp $
+# RCS: @(#) $Id: package.tcl,v 1.37 2009/07/26 11:40:23 dkf Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -16,9 +16,9 @@ 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.
+# 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
@@ -59,11 +59,10 @@ proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
}
# 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.
+# 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
@@ -134,16 +133,17 @@ proc pkg_mkIndex {args} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
- if {[catch {
- glob -directory $dir -tails -types {r f} -- {*}$patternList
- } fileList o]} {
- return -options $o $fileList
+ 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.
+ # interpreter, and get a list of the new commands and packages that
+ # are defined.
if {$file eq "pkgIndex.tcl"} {
continue
@@ -171,14 +171,17 @@ proc pkg_mkIndex {args} {
if {$doVerbose} {
tclLog "package [lindex $pkg 1] matches '$loadPat'"
}
- if {[catch {
+ try {
load [lindex $pkg 0] [lindex $pkg 1] $c
- } err]} {
+ } on error err {
if {$doVerbose} {
- tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
+ tclLog "warning: load [lindex $pkg 0]\
+ [lindex $pkg 1]\nfailed with: $err"
+ }
+ } on ok {} {
+ if {$doVerbose} {
+ tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
- } elseif {$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.
@@ -187,21 +190,25 @@ proc pkg_mkIndex {args} {
}
$c eval {
- # Stub out the package command so packages can
- # require other packages.
+ # 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 }
+ 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.
+ # Stub out the unknown command so package can call into each other
+ # during their initialilzation.
proc unknown {args} {}
@@ -209,9 +216,9 @@ proc pkg_mkIndex {args} {
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.
+ # 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
@@ -232,22 +239,22 @@ proc pkg_mkIndex {args} {
$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.
+ # 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]]
}
- if {[catch {
+ 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.
+ # 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
@@ -269,18 +276,17 @@ proc pkg_mkIndex {args} {
}
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.
+ # 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.
+ # 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]
@@ -291,11 +297,10 @@ proc pkg_mkIndex {args} {
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.
+ # 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.
@@ -318,8 +323,9 @@ proc pkg_mkIndex {args} {
set ::tcl::abs [namespace origin $::tcl::x]
- # special case so that global names have no leading
- # ::, this is required by the unknown command
+ # 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]
@@ -334,8 +340,8 @@ proc pkg_mkIndex {args} {
}
}
- # Look through the packages that appeared, and if there is
- # a version provided, then record it
+ # 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 ""
@@ -345,12 +351,12 @@ proc pkg_mkIndex {args} {
}
}
}
- } msg] == 1} {
+ } on error msg {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "warning: error while $what $file: $msg"
}
- } else {
+ } on ok {} {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "successful $what of $file"
@@ -412,11 +418,10 @@ proc pkg_mkIndex {args} {
}
# 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.
+# 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.
@@ -447,12 +452,12 @@ proc tclPkgSetup {dir pkg version files} {
}
# 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.
+# 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.
@@ -465,8 +470,8 @@ proc tclPkgUnknown {name args} {
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
+ # 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]
@@ -478,24 +483,22 @@ proc tclPkgUnknown {name args} {
}
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
+ # 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)]} {
- set code [catch {source $file} msg opt]
- if {$code == 1 &&
- [lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
- [lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
+ try {
+ source $file
+ } trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
- }
- if {$code} {
+ } on error msg {
tclLog "error reading package index file $file: $msg"
- } else {
+ } on ok {} {
set procdDirs($dir) 1
}
}
@@ -506,16 +509,14 @@ proc tclPkgUnknown {name args} {
set file [file join $dir pkgIndex.tcl]
# safe interps usually don't have "file exists",
if {([interp issafe] || [file exists $file])} {
- set code [catch {source $file} msg opt]
- if {$code == 1 &&
- [lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
- [lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
+ try {
+ source $file
+ } trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
- }
- if {$code} {
+ } on error msg {
tclLog "error reading package index file $file: $msg"
- } else {
+ } on ok {} {
set procdDirs($dir) 1
}
}
@@ -523,12 +524,11 @@ proc tclPkgUnknown {name args} {
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.
+ # 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 {
@@ -540,11 +540,11 @@ proc tclPkgUnknown {name args} {
}
}
- # $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.
+ # $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)]
&& ([lsearch -exact $use_path $dir] == -1) } {
@@ -556,9 +556,9 @@ proc tclPkgUnknown {name args} {
}
# 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.
+# 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
@@ -567,7 +567,6 @@ proc tclPkgUnknown {name args} {
# 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]
@@ -577,8 +576,8 @@ proc tcl::MacOSXPkgUnknown {original name args} {
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
+ # 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]
@@ -595,28 +594,25 @@ proc tcl::MacOSXPkgUnknown {original name args} {
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
- set code [catch {source $file} msg opt]
- if {$code == 1 &&
- [lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
- [lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
+ try {
+ source $file
+ } trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
- }
- if {$code} {
+ } on error msg {
tclLog "error reading package index file $file: $msg"
- } else {
+ } 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.
+ # 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 {
@@ -628,11 +624,11 @@ proc tcl::MacOSXPkgUnknown {original name args} {
}
}
- # $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.
+ # $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)]
&& ([lsearch -exact $use_path $dir] == -1) } {
@@ -659,12 +655,12 @@ proc tcl::MacOSXPkgUnknown {original name args} {
#
# 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.
+# -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.
diff --git a/library/safe.tcl b/library/safe.tcl
index afdf639..5a3d4d0 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -9,20 +9,20 @@
#
# Copyright (c) 1996-1997 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.
#
-# RCS: @(#) $Id: safe.tcl,v 1.17 2008/06/25 17:40:03 andreas_kupries Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.18 2009/07/26 11:40:24 dkf Exp $
#
-# The implementation is based on namespaces. These naming conventions
-# are followed:
+# The implementation is based on namespaces. These naming conventions are
+# followed:
# Private procs starts with uppercase.
# Public procs are exported and starts with lowercase
#
# Needed utilities package
-package require opt 0.4.1;
+package require opt 0.4.1
# Create the safe namespace
namespace eval ::safe {
@@ -37,8 +37,8 @@ namespace eval ::safe {
#
####
- # Make sure that our temporary variable is local to this
- # namespace. [Bug 981733]
+ # Make sure that our temporary variable is local to this namespace. [Bug
+ # 981733]
variable temp
# Share the descriptions
@@ -55,28 +55,27 @@ namespace eval ::safe {
::tcl::OptKeyRegister {
{?slave? -name {} "name of the slave (optional)"}
} ::safe::interpCreate
- # adding the flags sub programs to the command program
- # (relying on Opt's internal implementation details)
+ # adding the flags sub programs to the command program (relying on Opt's
+ # internal implementation details)
lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
# init and configure (slave is needed)
::tcl::OptKeyRegister {
{slave -name {} "name of the slave"}
} ::safe::interpIC
- # adding the flags sub programs to the command program
- # (relying on Opt's internal implementation details)
+ # adding the flags sub programs to the command program (relying on Opt's
+ # internal implementation details)
lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
# temp not needed anymore
::tcl::OptKeyDelete $temp
-
- # Helper function to resolve the dual way of specifying staticsok
- # (either by -noStatics or -statics 0)
+ # Helper function to resolve the dual way of specifying staticsok (either
+ # by -noStatics or -statics 0)
proc InterpStatics {} {
foreach v {Args statics noStatics} {
upvar $v $v
}
- set flag [::tcl::OptProcArgGiven -noStatics];
+ set flag [::tcl::OptProcArgGiven -noStatics]
if {$flag && (!$noStatics == !$statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
@@ -95,9 +94,9 @@ namespace eval ::safe {
foreach v {Args nested nestedLoadOk} {
upvar $v $v
}
- set flag [::tcl::OptProcArgGiven -nestedLoadOk];
- # note that the test here is the opposite of the "InterpStatics"
- # one (it is not -noNested... because of the wanted default value)
+ set flag [::tcl::OptProcArgGiven -nestedLoadOk]
+ # note that the test here is the opposite of the "InterpStatics" one
+ # (it is not -noNested... because of the wanted default value)
if {$flag && (!$nestedLoadOk != !$nested)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
@@ -117,7 +116,6 @@ namespace eval ::safe {
#
####
-
# Interface/entry point function and front end for "Create"
proc interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
@@ -131,7 +129,7 @@ namespace eval ::safe {
return -code error "\"$slave\" is not an interpreter"
}
InterpInit $slave $accessPath \
- [InterpStatics] [InterpNested] $deleteHook;
+ [InterpStatics] [InterpNested] $deleteHook
}
proc CheckInterp {slave} {
@@ -141,27 +139,26 @@ namespace eval ::safe {
}
}
- # Interface/entry point function and front end for "Configure"
- # This code is awfully pedestrian because it would need
- # more coupling and support between the way we store the
- # configuration values in safe::interp's and the Opt package
- # Obviously we would like an OptConfigure
- # to avoid duplicating all this code everywhere. -> TODO
- # (the app should share or access easily the program/value
- # stored by opt)
- # This is even more complicated by the boolean flags with no values
- # that we had the bad idea to support for the sake of user simplicity
- # in create/init but which makes life hard in configure...
+ # Interface/entry point function and front end for "Configure". This code
+ # is awfully pedestrian because it would need more coupling and support
+ # between the way we store the configuration values in safe::interp's and
+ # the Opt package. Obviously we would like an OptConfigure to avoid
+ # duplicating all this code everywhere.
+ # -> TODO (the app should share or access easily the program/value stored
+ # by opt)
+
+ # This is even more complicated by the boolean flags with no values that
+ # we had the bad idea to support for the sake of user simplicity in
+ # create/init but which makes life hard in configure...
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc interpConfigure {args} {
switch [llength $args] {
1 {
- # If we have exactly 1 argument
- # the semantic is to return all the current configuration
- # We still call OptKeyParse though we know that "slave"
- # is our given argument because it also checks
- # for the "-help" option.
+ # If we have exactly 1 argument the semantic is to return all
+ # the current configuration. We still call OptKeyParse though
+ # we know that "slave" is our given argument because it also
+ # checks for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
set res {}
@@ -172,9 +169,10 @@ namespace eval ::safe {
join $res
}
2 {
- # If we have exactly 2 arguments
- # the semantic is a "configure get"
+ # If we have exactly 2 arguments the semantic is a "configure
+ # get"
::tcl::Lassign $args slave arg
+
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
@@ -201,11 +199,10 @@ namespace eval ::safe {
return [list -deleteHook [Set [DeleteHookName $slave]]]
}
-noStatics {
- # it is most probably a set in fact
- # but we would need then to jump to the set part
- # and it is not *sure* that it is a set action
- # that the user want, so force it to use the
- # unambigous -statics ?value? instead:
+ # it is most probably a set in fact but we would need
+ # then to jump to the set part and it is not *sure*
+ # that it is a set action that the user want, so force
+ # it to use the unambigous -statics ?value? instead:
return -code error\
"ambigous query (get or set -noStatics ?)\
use -statics instead"
@@ -221,26 +218,31 @@ namespace eval ::safe {
}
}
default {
- # Otherwise we want to parse the arguments like init and create
- # did
+ # Otherwise we want to parse the arguments like init and
+ # create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
- # Get the current (and not the default) values of
- # whatever has not been given:
+
+ # Get the current (and not the default) values of whatever has
+ # not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
set doreset 1
set accessPath [Set [PathListName $slave]]
} else {
set doreset 0
}
- if {(![::tcl::OptProcArgGiven -statics]) \
- && (![::tcl::OptProcArgGiven -noStatics]) } {
+ if {
+ ![::tcl::OptProcArgGiven -statics]
+ && ![::tcl::OptProcArgGiven -noStatics]
+ } then {
set statics [Set [StaticsOkName $slave]]
} else {
set statics [InterpStatics]
}
- if {([::tcl::OptProcArgGiven -nested]) \
- || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
+ if {
+ [::tcl::OptProcArgGiven -nested] ||
+ [::tcl::OptProcArgGiven -nestedLoadOk]
+ } then {
set nested [InterpNested]
} else {
set nested [Set [NestedOkName $slave]]
@@ -262,21 +264,19 @@ namespace eval ::safe {
}
}
-
####
#
# Functions that actually implements the exported APIs
#
####
-
#
# safe::InterpCreate : doing the real job
#
- # This procedure creates a safe slave and initializes it with the
- # safe base aliases.
- # NB: slave name must be simple alphanumeric string, no spaces,
- # no (), no {},... {because the state array is stored as part of the name}
+ # This procedure creates a safe slave and initializes it with the safe
+ # base aliases.
+ # NB: slave name must be simple alphanumeric string, no spaces, no (), no
+ # {},... {because the state array is stored as part of the name}
#
# Returns the slave name.
#
@@ -310,24 +310,22 @@ namespace eval ::safe {
InterpInit $slave $access_path $staticsok $nestedok $deletehook
}
-
#
# InterpSetConfig (was setAccessPath) :
- # Sets up slave virtual auto_path and corresponding structure
- # within the master. Also sets the tcl_library in the slave
- # to be the first directory in the path.
- # Nb: If you change the path after the slave has been initialized
- # you probably need to call "auto_reset" in the slave in order that it
- # gets the right auto_index() array values.
+ # Sets up slave virtual auto_path and corresponding structure within
+ # the master. Also sets the tcl_library in the slave to be the first
+ # directory in the path.
+ # NB: If you change the path after the slave has been initialized you
+ # probably need to call "auto_reset" in the slave in order that it gets
+ # the right auto_index() array values.
proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
-
# determine and store the access path if empty
if {$access_path eq ""} {
set access_path [uplevel \#0 set auto_path]
- # Make sure that tcl_library is in auto_path
- # and at the first position (needed by setAccessPath)
+ # Make sure that tcl_library is in auto_path and at the first
+ # position (needed by setAccessPath)
set where [lsearch -exact $access_path [info library]]
if {$where == -1} {
# not found, add it.
@@ -344,8 +342,8 @@ namespace eval ::safe {
}
# Add 1st level sub dirs (will searched by auto loading from tcl
- # code in the slave using glob and thus fail, so we add them
- # here so by default it works the same).
+ # code in the slave using glob and thus fail, so we add them here
+ # so by default it works the same).
set access_path [AddSubDirs $access_path]
}
@@ -369,10 +367,10 @@ namespace eval ::safe {
lappend slave_auto_path "\$[PathToken $i]"
incr i
}
- # Extend the access list with the paths used to look for Tcl
- # Modules. We safe the virtual form separately as well, as
- # syncing it with the slave has to be defered until the
- # necessary commands are present for setup.
+ # Extend the access list with the paths used to look for Tcl Modules.
+ # We save the virtual form separately as well, as syncing it with the
+ # slave has to be defered until the necessary commands are present for
+ # setup.
foreach dir [::tcl::tm::list] {
lappend access_path $dir
Set [PathToken $i $slave] $dir
@@ -395,8 +393,8 @@ namespace eval ::safe {
#
#
# FindInAccessPath:
- # Search for a real directory and returns its virtual Id
- # (including the "$")
+ # Search for a real directory and returns its virtual Id (including the
+ # "$")
proc ::safe::interpFindInAccessPath {slave path} {
set access_path [GetAccessPath $slave]
set where [lsearch -exact $access_path $path]
@@ -408,32 +406,33 @@ proc ::safe::interpFindInAccessPath {slave path} {
#
# addToAccessPath:
- # add (if needed) a real directory to access path
- # and return its virtual token (including the "$").
+ # add (if needed) a real directory to access path and return its
+ # virtual token (including the "$").
proc ::safe::interpAddToAccessPath {slave path} {
# first check if the directory is already in there
- if {![catch {interpFindInAccessPath $slave $path} res]} {
- return $res
- }
- # new one, add it:
- set nname [PathNumberName $slave]
- set n [Set $nname]
- Set [PathToken $n $slave] $path
+ try {
+ return [interpFindInAccessPath $slave $path]
+ } on error {} {
+ # new one, add it:
+ set nname [PathNumberName $slave]
+ set n [Set $nname]
+ Set [PathToken $n $slave] $path
- set token "\$[PathToken $n]"
+ set token "\$[PathToken $n]"
- Lappend [VirtualPathListName $slave] $token
- Lappend [PathListName $slave] $path
- Set $nname [expr {$n+1}]
+ Lappend [VirtualPathListName $slave] $token
+ Lappend [PathListName $slave] $path
+ Set $nname [expr {$n+1}]
- SyncAccessPath $slave
+ SyncAccessPath $slave
- return $token
+ return $token
+ }
}
# This procedure applies the initializations to an already existing
- # interpreter. It is useful when you want to install the safe base
- # aliases into a preexisting safe interpreter.
+ # interpreter. It is useful when you want to install the safe base aliases
+ # into a preexisting safe interpreter.
proc ::safe::InterpInit {
slave
access_path
@@ -441,76 +440,77 @@ proc ::safe::interpAddToAccessPath {slave path} {
nestedok
deletehook
} {
-
- # Configure will generate an access_path when access_path is
- # empty.
+ # Configure will generate an access_path when access_path is empty.
InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
# These aliases let the slave load files to define new commands
- # NB we need to add [namespace current], aliases are always
- # absolute paths.
- ::interp alias $slave source {} [namespace current]::AliasSource $slave
- ::interp alias $slave load {} [namespace current]::AliasLoad $slave
+ # NB we need to add [namespace current], aliases are always absolute
+ # paths.
+ ::interp alias $slave source {} \
+ [namespace current]::AliasSource $slave
+ ::interp alias $slave load {} \
+ [namespace current]::AliasLoad $slave
# This alias lets the slave use the encoding names, convertfrom,
- # convertto, and system, but not "encoding system <name>" to set
- # the system encoding.
+ # convertto, and system, but not "encoding system <name>" to set the
+ # system encoding.
- ::interp alias $slave encoding {} [namespace current]::AliasEncoding \
- $slave
+ ::interp alias $slave encoding {} \
+ [namespace current]::AliasEncoding $slave
# Handling Tcl Modules, we need a restricted form of Glob.
- ::interp alias $slave glob {} [namespace current]::AliasGlob \
- $slave
+ ::interp alias $slave glob {} \
+ [namespace current]::AliasGlob $slave
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
- AliasSubset $slave file file dir.* join root.* ext.* tail \
- path.* split
+ AliasSubset $slave file \
+ file dir.* join root.* ext.* tail path.* split
# This alias interposes on the 'exit' command and cleanly terminates
# the slave.
- ::interp alias $slave exit {} [namespace current]::interpDelete $slave
+ ::interp alias $slave exit {} \
+ [namespace current]::interpDelete $slave
- # The allowed slave variables already have been set
- # by Tcl_MakeSafe(3)
+ # The allowed slave variables already have been set by Tcl_MakeSafe(3)
+ # Source init.tcl and tm.tcl into the slave, to get auto_load and
+ # other procedures defined:
- # Source init.tcl and tm.tcl into the slave, to get auto_load
- # and other procedures defined:
-
- if {[catch {::interp eval $slave\
- {source [file join $tcl_library init.tcl]}} msg]} {
+ if {[catch {::interp eval $slave {
+ source [file join $tcl_library init.tcl]
+ }} msg]} then {
Log $slave "can't source init.tcl ($msg)"
error "can't source init.tcl into slave $slave ($msg)"
}
- if {[catch {::interp eval $slave \
- {source [file join $tcl_library tm.tcl]}} msg]} {
+ if {[catch {::interp eval $slave {
+ source [file join $tcl_library tm.tcl]
+ }} msg]} then {
Log $slave "can't source tm.tcl ($msg)"
error "can't source tm.tcl into slave $slave ($msg)"
}
- # Sync the paths used to search for Tcl modules. This can be
- # done only now, after tm.tcl was loaded.
- ::interp eval $slave [list ::tcl::tm::add {*}[Set [TmPathListName $slave]]]
+ # Sync the paths used to search for Tcl modules. This can be done only
+ # now, after tm.tcl was loaded.
+ ::interp eval $slave [list \
+ ::tcl::tm::add {*}[Set [TmPathListName $slave]] ]
return $slave
}
-
- # Add (only if needed, avoid duplicates) 1 level of
- # sub directories to an existing path list.
- # Also removes non directories from the returned list.
+ # Add (only if needed, avoid duplicates) 1 level of sub directories to an
+ # existing path list. Also removes non directories from the returned
+ # list.
proc AddSubDirs {pathList} {
set res {}
foreach dir $pathList {
if {[file isdirectory $dir]} {
- # check that we don't have it yet as a children
- # of a previous dir
+ # check that we don't have it yet as a children of a previous
+ # dir
if {[lsearch -exact $res $dir]<0} {
lappend res $dir
}
@@ -526,24 +526,25 @@ proc ::safe::interpAddToAccessPath {slave path} {
return $res
}
- # This procedure deletes a safe slave managed by Safe Tcl and
- # cleans up associated state:
+ # This procedure deletes a safe slave managed by Safe Tcl and cleans up
+ # associated state:
proc ::safe::interpDelete {slave} {
-
Log $slave "About to delete" NOTICE
- # If the slave has a cleanup hook registered, call it.
- # check the existance because we might be called to delete an interp
- # which has not been registered with us at all
+ # If the slave has a cleanup hook registered, call it. Check the
+ # existance because we might be called to delete an interp which has
+ # not been registered with us at all
set hookname [DeleteHookName $slave]
if {[Exists $hookname]} {
set hook [Set $hookname]
if {![::tcl::Lempty $hook]} {
- # remove the hook now, otherwise if the hook
- # calls us somehow, we'll loop
+ # remove the hook now, otherwise if the hook calls us somehow,
+ # we'll loop
Unset $hookname
- if {[catch {{*}$hook $slave} err]} {
+ try {
+ {*}$hook $slave
+ } on error err {
Log $slave "Delete hook error ($err)"
}
}
@@ -570,27 +571,24 @@ proc ::safe::interpDelete {slave} {
# Set (or get) the loging mecanism
proc ::safe::setLogCmd {args} {
- variable Log
- if {[llength $args] == 0} {
- return $Log
- } else {
- if {[llength $args] == 1} {
+ variable Log
+ if {[llength $args] == 0} {
+ return $Log
+ } elseif {[llength $args] == 1} {
set Log [lindex $args 0]
} else {
set Log $args
}
}
-}
# internal variable
variable Log {}
# ------------------- END OF PUBLIC METHODS ------------
-
#
- # sets the slave auto_path to the master recorded value.
- # also sets tcl_library to the first token of the virtual path.
+ # Sets the slave auto_path to the master recorded value. Also sets
+ # tcl_library to the first token of the virtual path.
#
proc SyncAccessPath {slave} {
set slave_auto_path [Set [VirtualPathListName $slave]]
@@ -600,12 +598,10 @@ proc ::safe::setLogCmd {args} {
::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]
}
- # base name for storing all the slave states
- # the array variable name for slave foo is thus "Sfoo"
- # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
- # ok everywhere (or should))
- # We add the S prefix to avoid that a slave interp called "Log"
- # would smash our "Log" variable.
+ # Base name for storing all the slave states. The array variable name for
+ # slave foo is thus "Sfoo" and for sub slave {foo bar} "Sfoo bar" (spaces
+ # are handled ok everywhere (or should)). We add the S prefix to avoid
+ # that a slave interp called "Log" would smash our "Log" variable.
proc InterpStateName {slave} {
return "S$slave"
}
@@ -615,16 +611,14 @@ proc ::safe::setLogCmd {args} {
expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}
}
- # returns the virtual token for directory number N
- # if the slave argument is given,
- # it will return the corresponding master global variable name
+ # Returns the virtual token for directory number N. If the slave argument
+ # is given, it will return the corresponding master global variable name
proc PathToken {n {slave ""}} {
if {$slave ne ""} {
return "[InterpStateName $slave](access_path,$n)"
} else {
- # We need to have a ":" in the token string so
- # [file join] on the mac won't turn it into a relative
- # path.
+ # We need to have a ":" in the token string so [file join] on the
+ # mac won't turn it into a relative path.
return "p(:$n:)"
}
}
@@ -693,8 +687,8 @@ proc ::safe::setLogCmd {args} {
# translate virtual path into real path
#
proc TranslatePath {slave path} {
- # somehow strip the namespaces 'functionality' out (the danger
- # is that we would strip valid macintosh "../" queries... :
+ # somehow strip the namespaces 'functionality' out (the danger is that
+ # we would strip valid macintosh "../" queries... :
if {[string match "*::*" $path] || [string match "*..*" $path]} {
error "invalid characters in path $path"
}
@@ -708,8 +702,8 @@ proc ::safe::setLogCmd {args} {
}
- # Log eventually log an error
- # to enable error logging, set Log to {puts stderr} for instance
+ # Log eventually log an error; to enable error logging, set Log to {puts
+ # stderr} for instance
proc Log {slave msg {type ERROR}} {
variable Log
if {[info exists Log] && [llength $Log]} {
@@ -718,13 +712,13 @@ proc ::safe::setLogCmd {args} {
}
- # file name control (limit access to files/ressources that should be
- # a valid tcl source file)
+ # file name control (limit access to files/resources that should be a
+ # valid tcl source file)
proc CheckFileName {slave file} {
# This used to limit what can be sourced to ".tcl" and forbid files
# with more than 1 dot and longer than 14 chars, but I changed that
- # for 8.4 as a safe interp has enough internal protection already
- # to allow sourcing anything. - hobbs
+ # for 8.4 as a safe interp has enough internal protection already to
+ # allow sourcing anything. - hobbs
if {![file exists $file]} {
# don't tell the file path
@@ -750,29 +744,37 @@ proc ::safe::setLogCmd {args} {
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
-nocomplain -
- -join { lappend cmd $opt ; incr at }
+ -join {
+ lappend cmd $opt
+ incr at
+ }
-directory {
- lappend cmd $opt ; incr at
+ lappend cmd $opt
+ incr at
set virtualdir [lindex $args $at]
# get the real path from the virtual one.
- if {[catch {set dir [TranslatePath $slave $virtualdir]} msg]} {
+ try {
+ set dir [TranslatePath $slave $virtualdir]
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check that the path is in the access path of that slave
- if {[catch {DirInAccessPath $slave $dir} msg]} {
+ try {
+ DirInAccessPath $slave $dir
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
- lappend cmd $dir ; incr at
+ lappend cmd $dir
+ incr at
}
pkgIndex.tcl {
- # Oops, this is globbing a subdirectory in regular
- # package search. That is not wanted. Abort,
- # handler does catch already (because glob was not
- # defined before). See package.tcl, lines 484ff in
- # tclPkgUnknown.
+ # Oops, this is globbing a subdirectory in regular package
+ # search. That is not wanted. Abort, handler does catch
+ # already (because glob was not defined before). See
+ # package.tcl, lines 484ff in tclPkgUnknown.
error "unknown command glob"
}
-* {
@@ -780,14 +782,17 @@ proc ::safe::setLogCmd {args} {
error "Safe base rejecting glob option '$opt'"
}
default {
- lappend cmd $opt ; incr at
+ lappend cmd $opt
+ incr at
}
}
}
Log $slave "GLOB = $cmd" NOTICE
- if {[catch {::interp invokehidden $slave glob {*}$cmd} msg]} {
+ try {
+ ::interp invokehidden $slave glob {*}$cmd
+ } on error msg {
Log $slave $msg
return -code error "script error"
}
@@ -808,11 +813,9 @@ proc ::safe::setLogCmd {args} {
# AliasSource is the target of the "source" alias in safe interpreters.
proc AliasSource {slave args} {
-
set argc [llength $args]
- # Extended for handling of Tcl Modules to allow not only
- # "source filename", but "source -encoding E filename" as
- # well.
+ # Extended for handling of Tcl Modules to allow not only "source
+ # filename", but "source -encoding E filename" as well.
if {[lindex $args 0] eq "-encoding"} {
incr argc -2
set encoding [lrange $args 0 1]
@@ -829,25 +832,34 @@ proc ::safe::setLogCmd {args} {
set file [lindex $args $at]
# get the real path from the virtual one.
- if {[catch {set file [TranslatePath $slave $file]} msg]} {
+ try {
+ set file [TranslatePath $slave $file]
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check that the path is in the access path of that slave
- if {[catch {FileInAccessPath $slave $file} msg]} {
+ try {
+ FileInAccessPath $slave $file
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# do the checks on the filename :
- if {[catch {CheckFileName $slave $file} msg]} {
+ try {
+ CheckFileName $slave $file
+ } on error msg {
Log $slave "$file:$msg"
return -code error $msg
}
# passed all the tests , lets source it:
- if {[catch {::interp invokehidden $slave source {*}$encoding $file} msg]} {
+ if {[catch {
+ # We use catch here because we want to catch non-error/ok too
+ ::interp invokehidden $slave source {*}$encoding $file
+ } msg]} then {
Log $slave $msg
return -code error "script error"
}
@@ -857,7 +869,6 @@ proc ::safe::setLogCmd {args} {
# AliasLoad is the target of the "load" alias in safe interpreters.
proc AliasLoad {slave file args} {
-
set argc [llength $args]
if {$argc > 2} {
set msg "load error: too many arguments"
@@ -868,18 +879,17 @@ proc ::safe::setLogCmd {args} {
# package name (can be empty if file is not).
set package [lindex $args 0]
- # Determine where to load. load use a relative interp path
- # and {} means self, so we can directly and safely use passed arg.
+ # Determine where to load. load use a relative interp path and {}
+ # means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
if {$target ne ""} {
- # we will try to load into a sub sub interp
- # check that we want to authorize that.
+ # we will try to load into a sub sub interp; check that we want to
+ # authorize that.
if {![NestedOk $slave]} {
Log $slave "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
-
}
# Determine what kind of load is requested
@@ -899,20 +909,25 @@ proc ::safe::setLogCmd {args} {
# file loading
# get the real path from the virtual one.
- if {[catch {set file [TranslatePath $slave $file]} msg]} {
+ try {
+ set file [TranslatePath $slave $file]
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check the translated path
- if {[catch {FileInAccessPath $slave $file} msg]} {
+ try {
+ FileInAccessPath $slave $file
+ } on error msg {
Log $slave $msg
return -code error "permission denied (path)"
}
}
- if {[catch {::interp invokehidden\
- $slave load $file $package $target} msg]} {
+ try {
+ ::interp invokehidden $slave load $file $package $target
+ } on error msg {
Log $slave $msg
return -code error $msg
}
@@ -920,14 +935,12 @@ proc ::safe::setLogCmd {args} {
return $msg
}
- # FileInAccessPath raises an error if the file is not found in
- # the list of directories contained in the (master side recorded) slave's
- # access path.
+ # FileInAccessPath raises an error if the file is not found in the list of
+ # directories contained in the (master side recorded) slave's access path.
# the security here relies on "file dirname" answering the proper
- # result.... needs checking ?
+ # result... needs checking ?
proc FileInAccessPath {slave file} {
-
set access_path [GetAccessPath $slave]
if {[file isdirectory $file]} {
@@ -942,7 +955,7 @@ proc ::safe::setLogCmd {args} {
lappend norm_access_path [file normalize $path]
}
- if {[lsearch -exact $norm_access_path $norm_parent] == -1} {
+ if {$norm_parent ni $norm_access_path} {
error "\"$file\": not in access_path"
}
}
@@ -961,13 +974,13 @@ proc ::safe::setLogCmd {args} {
lappend norm_access_path [file normalize $path]
}
- if {[lsearch -exact $norm_access_path $norm_dir] == -1} {
+ if {$norm_dir ni $norm_access_path} {
error "\"$dir\": not in access_path"
}
}
- # This procedure enables access from a safe interpreter to only a subset of
- # the subcommands of a command:
+ # This procedure enables access from a safe interpreter to only a subset
+ # of the subcommands of a command:
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
@@ -979,20 +992,21 @@ proc ::safe::setLogCmd {args} {
error $msg
}
- # This procedure installs an alias in a slave that invokes "safesubset"
- # in the master to execute allowed subcommands. It precomputes the pattern
- # of allowed subcommands; you can use wildcards in the pattern if you wish
- # to allow subcommand abbreviation.
+ # This procedure installs an alias in a slave that invokes "safesubset" in
+ # the master to execute allowed subcommands. It precomputes the pattern of
+ # allowed subcommands; you can use wildcards in the pattern if you wish to
+ # allow subcommand abbreviation.
#
# Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
proc AliasSubset {slave alias target args} {
- set pat ^(; set sep ""
+ set pat "^("
+ set sep ""
foreach sub $args {
append pat $sep$sub
set sep |
}
- append pat )\$
+ append pat ")\$"
::interp alias $slave $alias {}\
[namespace current]::Subset $slave $target $pat
}
@@ -1000,7 +1014,6 @@ proc ::safe::setLogCmd {args} {
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc AliasEncoding {slave args} {
-
set argc [llength $args]
set okpat "^(name.*|convert.*)\$"
@@ -1013,23 +1026,18 @@ proc ::safe::setLogCmd {args} {
if {[string first $subcommand system] == 0} {
if {$argc == 1} {
# passed all the tests , lets source it:
- if {[catch {::interp invokehidden \
- $slave encoding system} msg]} {
+ try {
+ return [::interp invokehidden $slave encoding system]
+ } on error msg {
Log $slave $msg
return -code error "script error"
}
- } else {
- set msg "wrong # args: should be \"encoding system\""
- Log $slave $msg
- error $msg
}
+ set msg "wrong # args: should be \"encoding system\""
} else {
set msg "wrong # args: should be \"encoding option ?arg ...?\""
- Log $slave $msg
- error $msg
}
-
- return $msg
+ Log $slave $msg
+ error $msg
}
-
}
diff --git a/library/tm.tcl b/library/tm.tcl
index a2476ce..ca0bbf7 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -1,48 +1,44 @@
# -*- tcl -*-
#
-# Searching for Tcl Modules. Defines a procedure, declares it as the
-# primary command for finding packages, however also uses the former
-# 'package unknown' command as a fallback.
+# Searching for Tcl Modules. Defines a procedure, declares it as the primary
+# command for finding packages, however also uses the former 'package unknown'
+# command as a fallback.
#
-# Locates all possible packages in a directory via a less restricted
-# glob. The targeted directory is derived from the name of the
-# requested package. I.e. the TM scan will look only at directories
-# which can contain the requested package. It will register all
-# packages it found in the directory so that future requests have a
-# higher chance of being fulfilled by the ifneeded database without
-# having to come to us again.
+# Locates all possible packages in a directory via a less restricted glob. The
+# targeted directory is derived from the name of the requested package, i.e.
+# the TM scan will look only at directories which can contain the requested
+# package. It will register all packages it found in the directory so that
+# future requests have a higher chance of being fulfilled by the ifneeded
+# database without having to come to us again.
#
-# We do not remember where we have been and simply rescan targeted
-# directories when invoked again. The reasoning is this:
+# We do not remember where we have been and simply rescan targeted directories
+# when invoked again. The reasoning is this:
#
-# - The only way we get back to the same directory is if someone is
-# trying to [package require] something that wasn't there on the
-# first scan.
+# - The only way we get back to the same directory is if someone is trying to
+# [package require] something that wasn't there on the first scan.
#
# Either
# 1) It is there now: If we rescan, you get it; if not you don't.
#
-# This covers the possibility that the application asked for a
-# package late, and the package was actually added to the
-# installation after the application was started. It shoukld
-# still be able to find it.
+# This covers the possibility that the application asked for a package
+# late, and the package was actually added to the installation after the
+# application was started. It shoukld still be able to find it.
#
-# 2) It still is not there: Either way, you don't get it, but the
-# rescan takes time. This is however an error case and we dont't
-# care that much about it
+# 2) It still is not there: Either way, you don't get it, but the rescan
+# takes time. This is however an error case and we dont't care that much
+# about it
#
-# 3) It was there the first time; but for some reason a "package
-# forget" has been run, and "package" doesn't know about it
-# anymore.
+# 3) It was there the first time; but for some reason a "package forget" has
+# been run, and "package" doesn't know about it anymore.
#
-# This can be an indication that the application wishes to reload
-# some functionality. And should work as well.
+# This can be an indication that the application wishes to reload some
+# functionality. And should work as well.
#
-# Note that this also strikes a balance between doing a glob targeting
-# a single package, and thus most likely requiring multiple globs of
-# the same directory when the application is asking for many packages,
-# and trying to glob for _everything_ in all subdirectories when
-# looking for a package, which comes with a heavy startup cost.
+# Note that this also strikes a balance between doing a glob targeting a
+# single package, and thus most likely requiring multiple globs of the same
+# directory when the application is asking for many packages, and trying to
+# glob for _everything_ in all subdirectories when looking for a package,
+# which comes with a heavy startup cost.
#
# We scan for regular packages only if no satisfying module was found.
@@ -71,35 +67,33 @@ namespace eval ::tcl::tm {
# path with 'list'.
#
# Results
-# No result for subcommands 'add' and 'remove'. A list of paths
-# for 'list'.
+# No result for subcommands 'add' and 'remove'. A list of paths for
+# 'list'.
#
# Sideeffects
-# The subcommands 'add' and 'remove' manipulate the list of
-# paths to search for Tcl Modules. The subcommand 'list' has no
-# sideeffects.
+# The subcommands 'add' and 'remove' manipulate the list of paths to
+# search for Tcl Modules. The subcommand 'list' has no sideeffects.
proc ::tcl::tm::add {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
#
# The path is added at the head to the list of module paths.
#
- # The command enforces the restriction that no path may be an
- # ancestor directory of any other path on the list. If the new
- # path violates this restriction an error wil be raised.
+ # The command enforces the restriction that no path may be an ancestor
+ # directory of any other path on the list. If the new path violates this
+ # restriction an error wil be raised.
#
- # If the path is already present as is no error will be raised and
- # no action will be taken.
+ # If the path is already present as is no error will be raised and no
+ # action will be taken.
variable paths
- # We use a copy of the path as source during validation, and
- # extend it as well. Because we not only have to detect if the new
- # paths are bogus with respect to the existing paths, but also
- # between themselves. Otherwise we can still add bogus paths, by
- # specifying them in a single call. This makes the use of the new
- # paths simpler as well, a trivial assignment of the collected
- # paths to the official state var.
+ # We use a copy of the path as source during validation, and extend it as
+ # well. Because we not only have to detect if the new paths are bogus with
+ # respect to the existing paths, but also between themselves. Otherwise we
+ # can still add bogus paths, by specifying them in a single call. This
+ # makes the use of the new paths simpler as well, a trivial assignment of
+ # the collected paths to the official state var.
set newpaths $paths
foreach p $args {
@@ -108,9 +102,8 @@ proc ::tcl::tm::add {args} {
continue
}
- # Search for paths which are subdirectories of the new one. If
- # there are any then the new path violates the restriction
- # about ancestors.
+ # Search for paths which are subdirectories of the new one. If there
+ # are any then the new path violates the restriction about ancestors.
set pos [lsearch -glob $newpaths ${p}/*]
# Cannot use "in", we need the position for the message.
@@ -119,10 +112,9 @@ proc ::tcl::tm::add {args} {
"$p is ancestor of existing module path [lindex $newpaths $pos]."
}
- # Now look for existing paths which are ancestors of the new
- # one. This reverse question forces us to loop over the
- # existing paths, as each element is the pattern, not the new
- # path :(
+ # Now look for existing paths which are ancestors of the new one. This
+ # reverse question forces us to loop over the existing paths, as each
+ # element is the pattern, not the new path :(
foreach ep $newpaths {
if {[string match ${ep}/* $p]} {
@@ -134,10 +126,9 @@ proc ::tcl::tm::add {args} {
set newpaths [linsert $newpaths 0 $p]
}
- # The validation of the input is complete and successful, and
- # everything in newpaths is either an old path, or added. We can
- # now extend the official list of paths, a simple assignment is
- # sufficient.
+ # The validation of the input is complete and successful, and everything
+ # in newpaths is either an old path, or added. We can now extend the
+ # official list of paths, a simple assignment is sufficient.
set paths $newpaths
return
@@ -146,8 +137,8 @@ proc ::tcl::tm::add {args} {
proc ::tcl::tm::remove {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
#
- # Removes the path from the list of module paths. The command is
- # silently ignored if the path is not on the list.
+ # Removes the path from the list of module paths. The command is silently
+ # ignored if the path is not on the list.
variable paths
@@ -177,17 +168,16 @@ proc ::tcl::tm::list {} {
# empty string.
# exact - Either -exact or ommitted.
#
-# Name, version, and exact are used to determine
-# satisfaction. The original is called iff no satisfaction was
-# achieved. The name is also used to compute the directory to
-# target in the search.
+# Name, version, and exact are used to determine satisfaction. The
+# original is called iff no satisfaction was achieved. The name is also
+# used to compute the directory to target in the search.
#
# Results
# None.
#
# Sideeffects
-# May populate the package ifneeded database with additional
-# provide scripts.
+# May populate the package ifneeded database with additional provide
+# scripts.
proc ::tcl::tm::UnknownHandler {original name args} {
# Import the list of paths to search for packages in module form.
@@ -196,8 +186,8 @@ proc ::tcl::tm::UnknownHandler {original name args} {
variable paths
variable pkgpattern
- # Without paths to search we can do nothing. (Except falling back
- # to the regular search).
+ # Without paths to search we can do nothing. (Except falling back to the
+ # regular search).
if {[llength $paths]} {
set pkgpath [string map {:: /} $name]
@@ -206,11 +196,10 @@ proc ::tcl::tm::UnknownHandler {original name args} {
set pkgroot ""
}
- # We don't remember a copy of the paths while looping. Tcl
- # Modules are unable to change the list while we are searching
- # for them. This also simplifies the loop, as we cannot get
- # additional directories while iterating over the list. A
- # simple foreach is sufficient.
+ # We don't remember a copy of the paths while looping. Tcl Modules are
+ # unable to change the list while we are searching for them. This also
+ # simplifies the loop, as we cannot get additional directories while
+ # iterating over the list. A simple foreach is sufficient.
set satisfied 0
foreach path $paths {
@@ -223,12 +212,11 @@ proc ::tcl::tm::UnknownHandler {original name args} {
}
set strip [llength [file split $path]]
- # We can't use glob in safe interps, so enclose the following
- # in a catch statement, where we get the module files out
- # of the subdirectories. In other words, Tcl Modules are
- # not-functional in such an interpreter. This is the same
- # as for the command "tclPkgUnknown", i.e. the search for
- # regular packages.
+ # We can't use glob in safe interps, so enclose the following in a
+ # catch statement, where we get the module files out of the
+ # subdirectories. In other words, Tcl Modules are not-functional
+ # in such an interpreter. This is the same as for the command
+ # "tclPkgUnknown", i.e. the search for regular packages.
catch {
# We always look for _all_ possible modules in the current
@@ -238,50 +226,50 @@ proc ::tcl::tm::UnknownHandler {original name args} {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
- # Ignore everything not matching our pattern
- # for package names.
+ # Ignore everything not matching our pattern for
+ # package names.
continue
}
- if {[catch {package vcompare $pkgversion 0}]} {
- # Ignore everything where the version part is
- # not acceptable to "package vcompare".
+ try {
+ package vcompare $pkgversion 0
+ } on error {} {
+ # Ignore everything where the version part is not
+ # acceptable to "package vcompare".
continue
}
- # We have found a candidate, generate a "provide
- # script" for it, and remember it. Note that we
- # are using ::list to do this; locally [list]
- # means something else without the namespace
- # specifier.
-
- # NOTE. When making changes to the format of the
- # provide command generated below CHECK that the
- # 'LOCATE' procedure in core file
- # 'platform/shell.tcl' still understands it, or,
- # if not, update its implementation appropriately.
+ # We have found a candidate, generate a "provide script"
+ # for it, and remember it. Note that we are using ::list
+ # to do this; locally [list] means something else without
+ # the namespace specifier.
+
+ # NOTE. When making changes to the format of the provide
+ # command generated below CHECK that the 'LOCATE'
+ # procedure in core file 'platform/shell.tcl' still
+ # understands it, or, if not, update its implementation
+ # appropriately.
#
- # Right now LOCATE's implementation assumes that
- # the path of the package file is the last element
- # in the list.
+ # Right now LOCATE's implementation assumes that the path
+ # of the package file is the last element in the list.
package ifneeded $pkgname $pkgversion \
"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
- # We abort in this unknown handler only if we got
- # a satisfying candidate for the requested
- # package. Otherwise we still have to fallback to
- # the regular package search to complete the
- # processing.
+ # We abort in this unknown handler only if we got a
+ # satisfying candidate for the requested package.
+ # Otherwise we still have to fallback to the regular
+ # package search to complete the processing.
if {
($pkgname eq $name) &&
[package vsatisfies $pkgversion {*}$args]
} then {
set satisfied 1
- # We do not abort the loop, and keep adding
- # provide scripts for every candidate in the
- # directory, just remember to not fall back to
- # the regular search anymore.
+
+ # We do not abort the loop, and keep adding provide
+ # scripts for every candidate in the directory, just
+ # remember to not fall back to the regular search
+ # anymore.
}
}
}
@@ -292,8 +280,8 @@ proc ::tcl::tm::UnknownHandler {original name args} {
}
}
- # Fallback to previous command, if existing. See comment above
- # about ::list...
+ # Fallback to previous command, if existing. See comment above about
+ # ::list...
if {[llength $original]} {
uplevel 1 $original [::linsert $args 0 $name]
@@ -374,7 +362,7 @@ proc ::tcl::tm::roots {paths} {
return
}
-# Initialization. Set up the default paths, then insert the new
-# handler into the chain.
+# Initialization. Set up the default paths, then insert the new handler into
+# the chain.
if {![interp issafe]} { ::tcl::tm::Defaults }