summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--doc/safe.n10
-rw-r--r--library/package.tcl10
-rw-r--r--library/safe.tcl234
-rw-r--r--library/tm.tcl11
-rw-r--r--tests/auto0/auto1/file1.tcl3
-rw-r--r--tests/auto0/auto1/package1.tcl5
-rw-r--r--tests/auto0/auto1/pkgIndex.tcl11
-rw-r--r--tests/auto0/auto1/tclIndex9
-rw-r--r--tests/auto0/auto2/file2.tcl3
-rw-r--r--tests/auto0/auto2/package2.tcl5
-rw-r--r--tests/auto0/auto2/pkgIndex.tcl11
-rw-r--r--tests/auto0/auto2/tclIndex9
-rw-r--r--tests/auto0/modules/mod1/test1-1.0.tm5
-rw-r--r--tests/auto0/modules/mod2/test2-2.0.tm5
-rw-r--r--tests/auto0/modules/test0-0.5.tm5
-rw-r--r--tests/safe-stock86.test116
-rw-r--r--tests/safe.test921
17 files changed, 1279 insertions, 94 deletions
diff --git a/doc/safe.n b/doc/safe.n
index b39f2c2..7ddb182 100644
--- a/doc/safe.n
+++ b/doc/safe.n
@@ -72,11 +72,19 @@ See the \fBOPTIONS\fR section below for a description of the
optional arguments.
If the \fIslave\fR argument is omitted, a name will be generated.
\fB::safe::interpCreate\fR always returns the interpreter name.
+.sp
+The interpreter name \fIslave\fR may include namespace separators,
+but may not have leading or trailing namespace separators, or excess
+colon characters in namespace separators. The interpreter name is
+qualified relative to the global namespace ::, not the namespace in which
+the \fB::safe::interpCreate\fR command is evaluated.
.TP
\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
This command is similar to \fBinterpCreate\fR except it that does not
create the safe interpreter. \fIslave\fR must have been created by some
-other means, like \fBinterp create\fR \fB\-safe\fR.
+other means, like \fBinterp create\fR \fB\-safe\fR. The interpreter
+name \fIslave\fR may include namespace separators, subject to the same
+restrictions as for \fBinterpCreate\fR.
.TP
\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
If no \fIoptions\fR are given, returns the settings for all options for the
diff --git a/library/package.tcl b/library/package.tcl
index 44e3b28..d6280ae 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -479,9 +479,12 @@ 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
+ # Get the pkgIndex.tcl files in subdirectories of auto_path directories.
+ # - Safe Base interpreters have a restricted "glob" command that
+ # works in this case.
+ # - The "catch" was essential when there was no safe glob and every
+ # call in a safe interp failed; it is retained only for corner
+ # cases in which the eventual call to glob returns an error.
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
@@ -585,6 +588,7 @@ proc tcl::MacOSXPkgUnknown {original name args} {
set tclSeenPath($dir) 1
# get the pkgIndex files out of the subdirectories
+ # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl.
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
diff --git a/library/safe.tcl b/library/safe.tcl
index 3429b9e..352b302 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -79,6 +79,7 @@ proc ::safe::InterpNested {} {
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
+ RejectExcessColons $slave
InterpCreate $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
@@ -88,13 +89,14 @@ proc ::safe::interpInit {args} {
if {![::interp exists $slave]} {
return -code error "\"$slave\" is not an interpreter"
}
+ RejectExcessColons $slave
InterpInit $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
# Check that the given slave is "one of us"
proc ::safe::CheckInterp {slave} {
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
if {![info exists state] || ![::interp exists $slave]} {
return -code error \
"\"$slave\" is not an interpreter managed by ::safe::"
@@ -123,7 +125,7 @@ proc ::safe::interpConfigure {args} {
# checks for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
return [join [list \
[list -accessPath $state(access_path)] \
@@ -146,7 +148,7 @@ proc ::safe::interpConfigure {args} {
return -code error [::tcl::OptFlagUsage $desc $arg]
}
CheckInterp $slave
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
@@ -187,15 +189,15 @@ proc ::safe::interpConfigure {args} {
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
# Get the current (and not the default) values of whatever has
# not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
- set doreset 1
+ set doreset 0
set accessPath $state(access_path)
} else {
- set doreset 0
+ set doreset 1
}
if {
![::tcl::OptProcArgGiven -statics]
@@ -225,7 +227,26 @@ proc ::safe::interpConfigure {args} {
} else {
Log $slave "successful auto_reset" NOTICE
}
+
+ # Sync the paths used to search for Tcl modules.
+ ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]}
+ if {[llength $state(tm_path_slave)] > 0} {
+ ::interp eval $slave [list \
+ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
+ }
+
+ # Remove stale "package ifneeded" data for non-loaded packages.
+ # - Not for loaded packages, because "package forget" erases
+ # data from "package provide" as well as "package ifneeded".
+ # - This is OK because the script cannot reload any version of
+ # the package unless it first does "package forget".
+ foreach pkg [::interp eval $slave {package names}] {
+ if {[::interp eval $slave [list package provide $pkg]] eq ""} {
+ ::interp eval $slave [list package forget $pkg]
+ }
+ }
}
+ return
}
}
}
@@ -264,8 +285,10 @@ proc ::safe::InterpCreate {
deletehook
} {
# Create the slave.
+ # If evaluated in ::safe, the interpreter command for foo is ::foo;
+ # but for foo::bar is safe::foo::bar. So evaluate in :: instead.
if {$slave ne ""} {
- ::interp create -safe $slave
+ namespace eval :: [list ::interp create -safe $slave]
} else {
# empty argument: generate slave name
set slave [::interp create -safe]
@@ -318,7 +341,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
# clear old autopath if it existed
# build new one
@@ -344,6 +367,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
}
set morepaths [::tcl::tm::list]
+ set firstpass 1
while {[llength $morepaths]} {
set addpaths $morepaths
set morepaths {}
@@ -352,6 +376,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
# Prevent the addition of dirs on the tm list to the
# result if they are already known.
if {[dict exists $remap_access_path $dir]} {
+ if {$firstpass} {
+ # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
+ # Later passes handle subdirectories, which belong in the
+ # access path but not in the module path.
+ lappend slave_tm_path [dict get $remap_access_path $dir]
+ }
continue
}
@@ -361,7 +391,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
- lappend slave_tm_path $token
+ if {$firstpass} {
+ # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
+ # Later passes handle subdirectories, which belong in the
+ # access path but not in the module path.
+ lappend slave_tm_path $token
+ }
incr i
# [Bug 2854929]
@@ -372,6 +407,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
# subdirectories.
lappend morepaths {*}[glob -nocomplain -directory $dir -type d *]
}
+ set firstpass 0
}
set state(access_path) $access_path
@@ -385,6 +421,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
set state(cleanupHook) $deletehook
SyncAccessPath $slave
+ return
}
#
@@ -393,10 +430,11 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
# Search for a real directory and returns its virtual Id (including the
# "$")
proc ::safe::interpFindInAccessPath {slave path} {
- namespace upvar ::safe S$slave state
+ CheckInterp $slave
+ namespace upvar ::safe [VarName $slave] state
if {![dict exists $state(access_path,remap) $path]} {
- return -code error "$path not found in access path $access_path"
+ return -code error "$path not found in access path"
}
return [dict get $state(access_path,remap) $path]
@@ -409,7 +447,8 @@ proc ::safe::interpFindInAccessPath {slave path} {
proc ::safe::interpAddToAccessPath {slave path} {
# first check if the directory is already in there
# (inlined interpFindInAccessPath).
- namespace upvar ::safe S$slave state
+ CheckInterp $slave
+ namespace upvar ::safe [VarName $slave] state
if {[dict exists $state(access_path,remap) $path]} {
return [dict get $state(access_path,remap) $path]
@@ -508,7 +547,7 @@ proc ::safe::InterpInit {
# Sync the paths used to search for Tcl modules. This can be done only
# now, after tm.tcl was loaded.
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
if {[llength $state(tm_path_slave)] > 0} {
::interp eval $slave [list \
::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
@@ -540,12 +579,27 @@ proc ::safe::AddSubDirs {pathList} {
}
# This procedure deletes a safe slave managed by Safe Tcl and cleans up
-# associated state:
+# associated state.
+# - The command will also delete non-Safe-Base interpreters.
+# - This is regrettable, but to avoid breaking existing code this should be
+# amended at the next major revision by uncommenting "CheckInterp".
proc ::safe::interpDelete {slave} {
Log $slave "About to delete" NOTICE
- namespace upvar ::safe S$slave state
+ # CheckInterp $slave
+ namespace upvar ::safe [VarName $slave] state
+
+ # When an interpreter is deleted with [interp delete], any sub-interpreters
+ # are deleted automatically, but this leaves behind their data in the Safe
+ # Base. To clean up properly, we call safe::interpDelete recursively on each
+ # Safe Base sub-interpreter, so each one is deleted cleanly and not by
+ # the automatic mechanism built into [interp delete].
+ foreach sub [interp slaves $slave] {
+ if {[info exists ::safe::[VarName [list $slave $sub]]]} {
+ ::safe::interpDelete [list $slave $sub]
+ }
+ }
# If the slave has a cleanup hook registered, call it. Check the
# existance because we might be called to delete an interp which has
@@ -617,7 +671,7 @@ proc ::safe::setLogCmd {args} {
# tcl_library to the first token of the virtual path.
#
proc ::safe::SyncAccessPath {slave} {
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
set slave_access_path $state(access_path,slave)
::interp eval $slave [list set auto_path $slave_access_path]
@@ -644,7 +698,7 @@ proc ::safe::PathToken {n} {
# translate virtual path into real path
#
proc ::safe::TranslatePath {slave path} {
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
# somehow strip the namespaces 'functionality' out (the danger is that
# we would strip valid macintosh "../" queries... :
@@ -712,11 +766,15 @@ proc ::safe::AliasGlob {slave args} {
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
- -nocomplain - -- - -join - -tails {
+ -nocomplain - -- - -tails {
lappend cmd $opt
set got($opt) 1
incr at
}
+ -join {
+ set got($opt) 1
+ incr at
+ }
-types - -type {
lappend cmd -types [lindex $args [incr at]]
incr at
@@ -730,13 +788,6 @@ proc ::safe::AliasGlob {slave args} {
set virtualdir [lindex $args [incr at]]
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.
- return -code error "unknown command glob"
- }
-* {
Log $slave "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
@@ -760,24 +811,40 @@ proc ::safe::AliasGlob {slave args} {
if {$got(-nocomplain)} return
return -code error "permission denied"
}
- lappend cmd -directory $dir
+ if {$got(--)} {
+ set cmd [linsert $cmd end-1 -directory $dir]
+ } else {
+ lappend cmd -directory $dir
+ }
+ } else {
+ # The code after this "if ... else" block would conspire to return with
+ # no results in this case, if it were allowed to proceed. Instead,
+ # return now and reduce the number of cases to be considered later.
+ Log $slave {option -directory must be supplied}
+ if {$got(-nocomplain)} return
+ return -code error "permission denied"
}
- # Apply the -join semantics ourselves
+ # Apply the -join semantics ourselves.
if {$got(-join)} {
set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
}
- # Process remaining pattern arguments
+ # Process the pattern arguments. If we've done a join there is only one
+ # pattern argument.
+
set firstPattern [llength $cmd]
foreach opt [lrange $args $at end] {
if {![regexp $dirPartRE $opt -> thedir thefile]} {
set thedir .
- } elseif {[string match ~* $thedir]} {
- set thedir ./$thedir
+ # The *.tm search comes here.
}
- if {$thedir eq "*" &&
- ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
+ # "Special" treatment for (joined) argument {*/pkgIndex.tcl}.
+ # Do the expansion of "*" here, and filter out any directories that are
+ # not in the access path. The outcome is to lappend to cmd a path of
+ # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir,
+ # after removing any subdir that are not in the access path.
+ if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} {
set mapped 0
foreach d [glob -directory [TranslatePath $slave $virtualdir] \
-types d -tails *] {
@@ -789,7 +856,25 @@ proc ::safe::AliasGlob {slave args} {
}
}
if {$mapped} continue
+ # Don't [continue] if */pkgIndex.tcl has no matches in the access
+ # path. The pattern will now receive the same treatment as a
+ # "non-special" pattern (and will fail because it includes a "*" in
+ # the directory name).
}
+ # Any directory pattern that is not an exact (i.e. non-glob) match to a
+ # directory in the access path will be rejected here.
+ # - Rejections include any directory pattern that has glob matching
+ # patterns "*", "?", backslashes, braces or square brackets, (UNLESS
+ # it corresponds to a genuine directory name AND that directory is in
+ # the access path).
+ # - The only "special matching characters" that remain in patterns for
+ # processing by glob are in the filename tail.
+ # - [file join $anything ~${foo}] is ~${foo}, which is not an exact
+ # match to any directory in the access path. Hence directory patterns
+ # that begin with "~" are rejected here. Tests safe-16.[5-8] check
+ # that "file join" remains as required and does not expand ~${foo}.
+ # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is
+ # how the present code avoids the bug. All tests safe-16.* relate.
try {
DirInAccessPath $slave [TranslatePath $slave \
[file join $virtualdir $thedir]]
@@ -807,8 +892,17 @@ proc ::safe::AliasGlob {slave args} {
return
}
try {
+ # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<<
+ # - Pattern arguments added to cmd have NOT been translated from tokens.
+ # Only the virtualdir is translated (to dir).
+ # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments,
+ # which are a list of names each with tail pkgIndex.tcl. The purpose
+ # of the call to glob is to remove the names for which the file does
+ # not exist.
set entries [::interp invokehidden $slave glob {*}$cmd]
} on error msg {
+ # This is the only place that a call with -nocomplain and no invalid
+ # "dash-options" can return an error.
Log $slave $msg
return -code error "script error"
}
@@ -870,12 +964,15 @@ proc ::safe::AliasSource {slave args} {
return -code error "permission denied"
}
- # do the checks on the filename :
+ # Check that the filename exists and is readable. If it is not, deliver
+ # this -errorcode so that caller in tclPkgUnknown does not write a message
+ # to tclLog. Has no effect on other callers of ::source, which are in
+ # "package ifneeded" scripts.
if {[catch {
CheckFileName $slave $realfile
} msg]} {
Log $slave "$realfile:$msg"
- return -code error $msg
+ return -code error -errorcode {POSIX EACCES} $msg
}
# Passed all the tests, lets source it. Note that we do this all manually
@@ -920,7 +1017,7 @@ proc ::safe::AliasLoad {slave file args} {
# package name (can be empty if file is not).
set package [lindex $args 0]
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
# Determine where to load. load use a relative interp path and {}
# means self, so we can directly and safely use passed arg.
@@ -971,6 +1068,13 @@ proc ::safe::AliasLoad {slave file args} {
try {
return [::interp invokehidden $slave load $file $package $target]
} on error msg {
+ # Some packages return no error message.
+ set msg0 "load of binary library for package $package failed"
+ if {$msg eq {}} {
+ set msg $msg0
+ } else {
+ set msg "$msg0: $msg"
+ }
Log $slave $msg
return -code error $msg
}
@@ -982,7 +1086,7 @@ proc ::safe::AliasLoad {slave file args} {
# the security here relies on "file dirname" answering the proper
# result... needs checking ?
proc ::safe::FileInAccessPath {slave file} {
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
set access_path $state(access_path)
if {[file isdirectory $file]} {
@@ -994,14 +1098,14 @@ proc ::safe::FileInAccessPath {slave file} {
# potential pathname anomalies.
set norm_parent [file normalize $parent]
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
if {$norm_parent ni $state(access_path,norm)} {
return -code error "\"$file\": not in access_path"
}
}
proc ::safe::DirInAccessPath {slave dir} {
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
set access_path $state(access_path)
if {[file isfile $dir]} {
@@ -1012,7 +1116,7 @@ proc ::safe::DirInAccessPath {slave dir} {
# potential pathname anomalies.
set norm_dir [file normalize $dir]
- namespace upvar ::safe S$slave state
+ namespace upvar ::safe [VarName $slave] state
if {$norm_dir ni $state(access_path,norm)} {
return -code error "\"$dir\": not in access_path"
}
@@ -1053,6 +1157,58 @@ proc ::safe::AliasExeName {slave} {
return ""
}
+# ------------------------------------------------------------------------------
+# Using Interpreter Names with Namespace Qualifiers
+# ------------------------------------------------------------------------------
+# (1) We wish to preserve compatibility with existing code, in which Safe Base
+# interpreter names have no namespace qualifiers.
+# (2) safe::interpCreate and the rest of the Safe Base previously could not
+# accept namespace qualifiers in an interpreter name.
+# (3) The interp command will accept namespace qualifiers in an interpreter
+# name, but accepts distinct interpreters that will have the same command
+# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974).
+# (4) To satisfy these constraints, Safe Base interpreter names will be fully
+# qualified namespace names with no excess colons and with the leading "::"
+# omitted.
+# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}.
+# Reject such names.
+# (6) We could:
+# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in
+# interpCreate, interpInit;
+# (b) OR accept such names and then translate to a compliant name in every
+# command.
+# The problem with (b) is that the user will expect to use the name with the
+# interp command and will find that it is not recognised.
+# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name
+# "::foo" works with all the Safe Base commands, but "interp eval ::foo"
+# fails.
+# So we choose (a).
+# (7) The command
+# namespace upvar ::safe S$slave state
+# becomes
+# namespace upvar ::safe [VarName $slave] state
+# ------------------------------------------------------------------------------
+
+proc ::safe::RejectExcessColons {slave} {
+ set stripped [regsub -all -- {:::*} $slave ::]
+ if {[string range $stripped end-1 end] eq {::}} {
+ return -code error {interpreter name must not end in "::"}
+ }
+ if {$stripped ne $slave} {
+ set msg {interpreter name has excess colons in namespace separators}
+ return -code error $msg
+ }
+ if {[string range $stripped 0 1] eq {::}} {
+ return -code error {interpreter name must not begin "::"}
+ }
+ return
+}
+
+proc ::safe::VarName {slave} {
+ # return S$slave
+ return S[string map {:: @N @ @A} $slave]
+}
+
proc ::safe::Setup {} {
####
#
diff --git a/library/tm.tcl b/library/tm.tcl
index 0ed3f1a..c60084c 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -212,11 +212,12 @@ 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.
+ # Get the module files out of the subdirectories.
+ # - Safe Base interpreters have a restricted "glob" command that
+ # works in this case.
+ # - The "catch" was essential when there was no safe glob and every
+ # call in a safe interp failed; it is retained only for corner
+ # cases in which the eventual call to glob returns an error.
catch {
# We always look for _all_ possible modules in the current
diff --git a/tests/auto0/auto1/file1.tcl b/tests/auto0/auto1/file1.tcl
new file mode 100644
index 0000000..bd8b92b
--- /dev/null
+++ b/tests/auto0/auto1/file1.tcl
@@ -0,0 +1,3 @@
+proc report1 {args} {
+ return ok1
+}
diff --git a/tests/auto0/auto1/package1.tcl b/tests/auto0/auto1/package1.tcl
new file mode 100644
index 0000000..32d7c56
--- /dev/null
+++ b/tests/auto0/auto1/package1.tcl
@@ -0,0 +1,5 @@
+proc HeresPackage1 {args} {
+ return OK1
+}
+
+package provide SafeTestPackage1 1.2.3
diff --git a/tests/auto0/auto1/pkgIndex.tcl b/tests/auto0/auto1/pkgIndex.tcl
new file mode 100644
index 0000000..babb6d5
--- /dev/null
+++ b/tests/auto0/auto1/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded SafeTestPackage1 1.2.3 [list source [file join $dir package1.tcl]]
diff --git a/tests/auto0/auto1/tclIndex b/tests/auto0/auto1/tclIndex
new file mode 100644
index 0000000..bbfa6d4
--- /dev/null
+++ b/tests/auto0/auto1/tclIndex
@@ -0,0 +1,9 @@
+# Tcl autoload index file, version 2.0
+# This file is generated by the "auto_mkindex" command
+# and sourced to set up indexing information for one or
+# more commands. Typically each line is a command that
+# sets an element in the auto_index array, where the
+# element name is the name of a command and the value is
+# a script that loads the command.
+
+set auto_index(report1) [list source [file join $dir file1.tcl]]
diff --git a/tests/auto0/auto2/file2.tcl b/tests/auto0/auto2/file2.tcl
new file mode 100644
index 0000000..5bc622f
--- /dev/null
+++ b/tests/auto0/auto2/file2.tcl
@@ -0,0 +1,3 @@
+proc report2 {args} {
+ return ok2
+}
diff --git a/tests/auto0/auto2/package2.tcl b/tests/auto0/auto2/package2.tcl
new file mode 100644
index 0000000..61774df
--- /dev/null
+++ b/tests/auto0/auto2/package2.tcl
@@ -0,0 +1,5 @@
+proc HeresPackage2 {args} {
+ return OK2
+}
+
+package provide SafeTestPackage2 2.3.4
diff --git a/tests/auto0/auto2/pkgIndex.tcl b/tests/auto0/auto2/pkgIndex.tcl
new file mode 100644
index 0000000..1022691
--- /dev/null
+++ b/tests/auto0/auto2/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded SafeTestPackage2 2.3.4 [list source [file join $dir package2.tcl]]
diff --git a/tests/auto0/auto2/tclIndex b/tests/auto0/auto2/tclIndex
new file mode 100644
index 0000000..9cd2a74
--- /dev/null
+++ b/tests/auto0/auto2/tclIndex
@@ -0,0 +1,9 @@
+# Tcl autoload index file, version 2.0
+# This file is generated by the "auto_mkindex" command
+# and sourced to set up indexing information for one or
+# more commands. Typically each line is a command that
+# sets an element in the auto_index array, where the
+# element name is the name of a command and the value is
+# a script that loads the command.
+
+set auto_index(report2) [list source [file join $dir file2.tcl]]
diff --git a/tests/auto0/modules/mod1/test1-1.0.tm b/tests/auto0/modules/mod1/test1-1.0.tm
new file mode 100644
index 0000000..927fa6f
--- /dev/null
+++ b/tests/auto0/modules/mod1/test1-1.0.tm
@@ -0,0 +1,5 @@
+namespace eval mod1::test1 {}
+
+proc mod1::test1::try1 args {
+ return res1
+}
diff --git a/tests/auto0/modules/mod2/test2-2.0.tm b/tests/auto0/modules/mod2/test2-2.0.tm
new file mode 100644
index 0000000..b5cd45b
--- /dev/null
+++ b/tests/auto0/modules/mod2/test2-2.0.tm
@@ -0,0 +1,5 @@
+namespace eval mod2::test2 {}
+
+proc mod2::test2::try2 args {
+ return res2
+}
diff --git a/tests/auto0/modules/test0-0.5.tm b/tests/auto0/modules/test0-0.5.tm
new file mode 100644
index 0000000..19f3613
--- /dev/null
+++ b/tests/auto0/modules/test0-0.5.tm
@@ -0,0 +1,5 @@
+namespace eval test0 {}
+
+proc test0::try0 args {
+ return res0
+}
diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test
new file mode 100644
index 0000000..ccfdd3f
--- /dev/null
+++ b/tests/safe-stock86.test
@@ -0,0 +1,116 @@
+# safe-stock86.test --
+#
+# This file contains tests for safe Tcl that were previously in the file
+# safe.test, and use files and packages of stock Tcl 8.6 to perform the tests.
+# These files may be changed or disappear in future revisions of Tcl,
+# for example package http 1.0 will be removed from Tcl 8.7.
+#
+# The tests are replaced in safe.tcl with tests that use files provided in the
+# tests directory. Test numbering is for comparison with similar tests in
+# safe.test.
+#
+# Sourcing this file into tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.5-
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+foreach i [interp slaves] {
+ interp delete $i
+}
+
+set SaveAutoPath $::auto_path
+set ::auto_path [info library]
+set TestsDir [file normalize [file dirname [info script]]]
+set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR]
+
+proc mapList {map listIn} {
+ set listOut {}
+ foreach element $listIn {
+ lappend listOut [string map $map $element]
+ }
+ return $listOut
+}
+
+# Force actual loading of the safe package because we use un-exported (and
+# thus un-autoindexed) APIs in this test result arguments:
+catch {safe::interpConfigure}
+
+# testing that nested and statics do what is advertised (we use a static
+# package - Tcltest - but it might be absent if we're in standard tclsh)
+
+testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]
+
+# high level general test
+test safe-stock86-7.1 {tests that everything works at high level, uses http 2} -body {
+ set i [safe::interpCreate]
+ # no error shall occur:
+ # (because the default access_path shall include 1st level sub dirs so
+ # package require in a slave works like in the master)
+ set v [interp eval $i {package require http 2}]
+ # no error shall occur:
+ interp eval $i {http::config}
+ safe::interpDelete $i
+ set v
+} -match glob -result 2.*
+test safe-stock86-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p1
+ set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ # an error shall occur (http is not anymore in the secure 0-level
+ # provided deep path)
+ list $token1 $token2 -- \
+ [catch {interp eval $i {package require http 1}} msg] $msg -- \
+ $mappA -- [safe::interpDelete $i]
+} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\
+ {TCLLIB */dummy/unixlike/test/path} -- {}}
+test safe-stock86-7.4 {tests specific path and positive search, uses http1.0} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p1
+ set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]]
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ # this time, unlike test safe-stock86-7.2, http should be found
+ list $token1 $token2 -- \
+ [catch {interp eval $i {package require http 1}} msg] $msg -- \
+ $mappA -- [safe::interpDelete $i]
+} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}}
+
+# The following test checks whether the definition of tcl_endOfWord can be
+# obtained from auto_loading. It was previously test "safe-5.1".
+test safe-stock86-9.8 {test auto-loading in safe interpreters, was test 5.1} -setup {
+ catch {safe::interpDelete a}
+ safe::interpCreate a
+} -body {
+ interp eval a {tcl_endOfWord "" 0}
+} -cleanup {
+ safe::interpDelete a
+} -result -1
+
+set ::auto_path $SaveAutoPath
+unset SaveAutoPath TestsDir PathMapp
+rename mapList {}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/safe.test b/tests/safe.test
index 11ad2a9..eba6057 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -4,6 +4,17 @@
# using safe interpreters. Sourcing this file into tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
+# The package http 1.0 is convenient for testing package loading, but will soon
+# be removed.
+# - Tests that use http are replaced here with tests that use example packages
+# provided in subdirectory auto0 of the tests directory, which are independent
+# of any changes made to the packages provided with Tcl itself.
+# - These are tests 7.1 7.2 7.4 9.11 9.13
+# - Tests 5.* test the example packages themselves before they
+# are used to test Safe Base interpreters.
+# - Alternative tests using stock packages of Tcl 8.6 are in file
+# safe-stock86.test.
+#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
@@ -21,10 +32,27 @@ foreach i [interp slaves] {
interp delete $i
}
-set saveAutoPath $::auto_path
+set SaveAutoPath $::auto_path
set ::auto_path [info library]
+set TestsDir [file normalize [file dirname [info script]]]
+set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR]
+
+proc mapList {map listIn} {
+ set listOut {}
+ foreach element $listIn {
+ lappend listOut [string map $map $element]
+ }
+ return $listOut
+}
+proc mapAndSortList {map listIn} {
+ set listOut {}
+ foreach element $listIn {
+ lappend listOut [string map $map $element]
+ }
+ lsort $listOut
+}
-# Force actual loading of the safe package because we use un exported (and
+# Force actual loading of the safe package because we use un-exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
@@ -66,6 +94,8 @@ test safe-2.2 {creating interpreters, should have no aliases} -setup {
a aliases
} -cleanup {
safe::interpDelete a
+ # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters
+ # is regrettable and should be removed at the next major revision.
} -result ""
test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup {
catch {safe::interpDelete a}
@@ -115,6 +145,8 @@ test safe-4.1 {safe::interpDelete} -setup {
} -body {
interp create a
safe::interpDelete a
+ # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters
+ # is regrettable and should be removed at the next major revision.
} -result ""
test safe-4.2 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
@@ -122,6 +154,8 @@ test safe-4.2 {safe::interpDelete, indirectly} -setup {
interp create a
a alias exit safe::interpDelete a
a eval exit
+ # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters
+ # is regrettable and should be removed at the next major revision.
} -result ""
test safe-4.5 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
@@ -138,17 +172,118 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup {
a eval exit
} -result ""
-# The following test checks whether the definition of tcl_endOfWord can be
-# obtained from auto_loading.
+# The old test "safe-5.1" has been moved to "safe-stock86-9.8".
+# A replacement test using example files is "safe-9.8".
+# Tests 5.* test the example files before using them to test safe interpreters.
-test safe-5.1 {test auto-loading in safe interpreters} -setup {
- catch {safe::interpDelete a}
- safe::interpCreate a
+test safe-5.1 {example tclIndex commands, test in master interpreter} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2]
} -body {
- interp eval a {tcl_endOfWord "" 0}
+ # Try to load the commands.
+ set code3 [catch report1 msg3]
+ set code4 [catch report2 msg4]
+ list $code3 $msg3 $code4 $msg4
} -cleanup {
- safe::interpDelete a
-} -result -1
+ catch {rename report1 {}}
+ catch {rename report2 {}}
+ set ::auto_path $tmpAutoPath
+ auto_reset
+} -match glob -result {0 ok1 0 ok2}
+test safe-5.2 {example tclIndex commands, negative test in master interpreter} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $TestsDir auto0]
+} -body {
+ # Try to load the commands.
+ set code3 [catch report1 msg3]
+ set code4 [catch report2 msg4]
+ list $code3 $msg3 $code4 $msg4
+} -cleanup {
+ catch {rename report1 {}}
+ catch {rename report2 {}}
+ set ::auto_path $tmpAutoPath
+ auto_reset
+} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}}
+test safe-5.3 {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $TestsDir auto0]
+} -body {
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {package require SafeTestPackage1} msg3]
+ set code4 [catch {package require SafeTestPackage2} msg4]
+ set code5 [catch HeresPackage1 msg5]
+ set code6 [catch HeresPackage2 msg6]
+ list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
+} -cleanup {
+ set ::auto_path $tmpAutoPath
+ catch {package forget SafeTestPackage1}
+ catch {package forget SafeTestPackage2}
+ catch {rename HeresPackage1 {}}
+ catch {rename HeresPackage2 {}}
+} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
+test safe-5.4 {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]
+} -body {
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {package require SafeTestPackage1} msg3]
+ set code4 [catch {package require SafeTestPackage2} msg4]
+ set code5 [catch HeresPackage1 msg5]
+ set code6 [catch HeresPackage2 msg6]
+ list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
+} -cleanup {
+ set ::auto_path $tmpAutoPath
+ catch {package forget SafeTestPackage1}
+ catch {package forget SafeTestPackage2}
+ catch {rename HeresPackage1 {}}
+ catch {rename HeresPackage2 {}}
+} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
+test safe-5.5 {example modules packages, test in master interpreter, replace path} -setup {
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ # Try to load the modules and run a command from each one.
+ set code0 [catch {package require test0} msg0]
+ set code1 [catch {package require mod1::test1} msg1]
+ set code2 [catch {package require mod2::test2} msg2]
+ set out0 [test0::try0]
+ set out1 [mod1::test1::try1]
+ set out2 [mod2::test2::try2]
+ list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ catch {package forget test0}
+ catch {package forget mod1::test1}
+ catch {package forget mod2::test2}
+ catch {namespace delete ::test0}
+ catch {namespace delete ::mod1}
+} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
+test safe-5.6 {example modules packages, test in master interpreter, append to path} -setup {
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ # Try to load the modules and run a command from each one.
+ set code0 [catch {package require test0} msg0]
+ set code1 [catch {package require mod1::test1} msg1]
+ set code2 [catch {package require mod2::test2} msg2]
+ set out0 [test0::try0]
+ set out1 [mod1::test1::try1]
+ set out2 [mod2::test2::try2]
+ list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ catch {package forget test0}
+ catch {package forget mod1::test1}
+ catch {package forget mod2::test2}
+ catch {namespace delete ::test0}
+ catch {namespace delete ::mod1}
+} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
# test safe interps 'information leak'
proc SafeEval {script} {
@@ -176,59 +311,121 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
lsort $r
} {byteOrder engine pathSeparator platform pointerSize wordSize}
+rename SafeEval {}
# More test should be added to check that hostname, nameofexecutable, aren't
# leaking infos, but they still do...
# high level general test
-test safe-7.1 {tests that everything works at high level} -body {
+# Use example packages not http1.0 etc
+test safe-7.1 {tests that everything works at high level} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $TestsDir auto0]
set i [safe::interpCreate]
+ set ::auto_path $tmpAutoPath
+} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a slave works like in the master)
- set v [interp eval $i {package require http 2}]
+ set v [interp eval $i {package require SafeTestPackage1}]
# no error shall occur:
- interp eval $i {http::config}
- safe::interpDelete $i
+ interp eval $i {HeresPackage1}
set v
-} -match glob -result 2.*
-test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result 1.2.3
+test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup {
+} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
- # should add as p1
+ # should add as p* (not p1 if master has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
- # an error shall occur (http is not anymore in the secure 0-level
+ # should add as p* (not p2 if master has a module path)
+ set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
# provided deep path)
- list $token1 $token2 \
- [catch {interp eval $i {package require http 1}} msg] $msg \
- [safe::interpConfigure $i]\
- [safe::interpDelete $i]
-} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
+ list $token1 $token2 $token3 -- \
+ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
+ $mappA -- [safe::interpDelete $i]
+} -cleanup {
+} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\
+ 1 {can't find package SafeTestPackage1} --\
+ {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}}
test safe-7.3 {check that safe subinterpreters work} {
+ set g [interp slaves]
+ if {$g ne {}} {
+ append g { -- residue of an earlier test}
+ }
+ set h [info vars ::safe::S*]
+ if {$h ne {}} {
+ append h { -- residue of an earlier test}
+ }
set i [safe::interpCreate]
set j [safe::interpCreate [list $i x]]
- list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j]
-} {ok {} 0}
+ list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \
+ [interp exists $j] [info vars ::safe::S*]
+} {{} {} ok {} 0 {}}
+test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup {
+} -body {
+ set g [interp slaves]
+ if {$g ne {}} {
+ append g { -- residue of an earlier test}
+ }
+ set h [info vars ::safe::S*]
+ if {$h ne {}} {
+ append h { -- residue of an earlier test}
+ }
+ set i [safe::interpCreate foo::bar]
+ set j [safe::interpCreate [list $i hello::world]]
+ list $g $h [interp eval $j {join {o k} ""}] \
+ [foo::bar eval {hello::world eval {join {o k} ""}}] \
+ [safe::interpDelete $i] \
+ [interp exists $j] [info vars ::safe::S*]
+} -match glob -result {{} {} ok ok {} 0 {}}
+test safe-7.4 {tests specific path and positive search} -setup {
+} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p* (not p1 if master has a module path)
+ set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]]
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ # this time, unlike test safe-7.2, SafeTestPackage1 should be found
+ list $token1 $token2 -- \
+ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
+ $mappA -- [safe::interpDelete $i]
+ # Note that the glob match elides directories (those from the module path)
+ # other than the first and last in the access path.
+} -cleanup {
+} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\
+ {TCLLIB * TESTSDIR/auto0/auto1} -- {}}
# test source control on file name
-set i "a"
test safe-8.1 {safe source control on file} -setup {
+ set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
$i eval {source}
} -returnCodes error -cleanup {
safe::interpDelete $i
+ unset i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.2 {safe source control on file} -setup {
+ set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
$i eval {source a b c d e}
} -returnCodes error -cleanup {
safe::interpDelete $i
+ unset i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.3 {safe source control on file} -setup {
+ set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {lappend ::log $str}
@@ -239,10 +436,12 @@ test safe-8.3 {safe source control on file} -setup {
list [catch {$i eval {source .}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
- unset log
safe::interpDelete $i
+ rename safe-test-log {}
+ unset i log
} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}}
test safe-8.4 {safe source control on file} -setup {
+ set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -253,10 +452,12 @@ test safe-8.4 {safe source control on file} -setup {
list [catch {$i eval {source /abc/def}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
- unset log
safe::interpDelete $i
+ rename safe-test-log {}
+ unset i log
} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}}
test safe-8.5 {safe source control on file} -setup {
+ set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -271,10 +472,12 @@ test safe-8.5 {safe source control on file} -setup {
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
- unset log
safe::interpDelete $i
+ rename safe-test-log {}
+ unset i log
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]]
test safe-8.6 {safe source control on file} -setup {
+ set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -287,10 +490,12 @@ test safe-8.6 {safe source control on file} -setup {
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
- unset log
safe::interpDelete $i
+ rename safe-test-log {}
+ unset i log
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]]
test safe-8.7 {safe source control on file} -setup {
+ set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -305,14 +510,16 @@ test safe-8.7 {safe source control on file} -setup {
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
- unset log
safe::interpDelete $i
+ rename safe-test-log {}
+ unset i log
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
test safe-8.8 {safe source forbids -rsrc} emptyTest {
# Disabled this test. It was only useful for long unsupported
# Mac OS 9 systems. [Bug 860a9f1945]
} {}
test safe-8.9 {safe source and return} -setup {
+ set i "a"
set returnScript [makeFile {return "ok"} return.tcl]
catch {safe::interpDelete $i}
} -body {
@@ -322,8 +529,10 @@ test safe-8.9 {safe source and return} -setup {
} -cleanup {
catch {safe::interpDelete $i}
removeFile $returnScript
+ unset i
} -result ok
test safe-8.10 {safe source and return} -setup {
+ set i "a"
set returnScript [makeFile {return -level 2 "ok"} return.tcl]
catch {safe::interpDelete $i}
} -body {
@@ -336,10 +545,11 @@ test safe-8.10 {safe source and return} -setup {
} -cleanup {
catch {safe::interpDelete $i}
removeFile $returnScript
+ unset i
} -result ok
-set i "a"
test safe-9.1 {safe interps' deleteHook} -setup {
+ set i "a"
catch {safe::interpDelete $i}
set res {}
} -body {
@@ -352,8 +562,12 @@ test safe-9.1 {safe interps' deleteHook} -setup {
}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"
list [interp eval $i exit] $res
+} -cleanup {
+ catch {rename testDelHook {}}
+ unset i res
} -result {{} {arg1 arg2 a}}
test safe-9.2 {safe interps' error in deleteHook} -setup {
+ set i "a"
catch {safe::interpDelete $i}
set res {}
set log {}
@@ -374,7 +588,9 @@ test safe-9.2 {safe interps' error in deleteHook} -setup {
list [safe::interpDelete $i] $res $log
} -cleanup {
safe::setLogCmd $prevlog
- unset log
+ catch {rename testDelHook {}}
+ rename safe-test-log {}
+ unset i log res
} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}}
test safe-9.3 {dual specification of statics} -returnCodes error -body {
safe::interpCreate -stat true -nostat
@@ -403,7 +619,546 @@ test safe-9.6 {interpConfigure widget like behaviour} -body {
safe::interpConfigure $i]\
[safe::interpConfigure $i -deleteHook toto -nosta -nested 0
safe::interpConfigure $i]
-} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}}
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\
+ {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
+ {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\
+ {-accessPath * -statics 0 -nested 0 -deleteHook toto}}
+test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body {
+ # this test shall work, believed equivalent to 9.6
+ set i [safe::interpCreate \
+ -noStatics \
+ -nestedLoadOk \
+ -deleteHook {foo bar}]
+ safe::interpConfigure $i -accessPath /foo/bar
+ set a [safe::interpConfigure $i]
+ set b [safe::interpConfigure $i -aCCess]
+ set c [safe::interpConfigure $i -nested]
+ set d [safe::interpConfigure $i -statics]
+ set e [safe::interpConfigure $i -DEL]
+ safe::interpConfigure $i -accessPath /blah -statics 1
+ set f [safe::interpConfigure $i]
+ safe::interpConfigure $i -deleteHook toto -nosta -nested 0
+ set g [safe::interpConfigure $i]
+
+ list $a $b $c $d $e $f $g
+} -cleanup {
+ safe::interpDelete $i
+ unset -nocomplain a b c d e f g i
+} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\
+ {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
+ {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\
+ {-accessPath * -statics 0 -nested 0 -deleteHook toto}}
+test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup {
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Load and run the commands.
+ set code1 [catch {interp eval $i {report1}} msg1]
+ set code2 [catch {interp eval $i {report2}} msg2]
+
+ list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}}
+test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup {
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Load auto_load data.
+ interp eval $i {catch nonExistentCommand}
+
+ # Load and run the commands.
+ # This guarantees the test will pass even if the tokens are swapped.
+ set code1 [catch {interp eval $i {report1}} msg1]
+ set code2 [catch {interp eval $i {report2}} msg2]
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Run the commands.
+ set code3 [catch {interp eval $i {report1}} msg3]
+ set code4 [catch {interp eval $i {report2}} msg4]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}}
+test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup {
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Load auto_load data.
+ interp eval $i {catch nonExistentCommand}
+
+ # Do not load the commands. With the tokens swapped, the test
+ # will pass only if the Safe Base has called auto_reset.
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Load and run the commands.
+ set code3 [catch {interp eval $i {report1}} msg3]
+ set code4 [catch {interp eval $i {report2}} msg4]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
+ 0 ok1 0 ok2 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}}
+test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup {
+} -body {
+ # For complete correspondence to safe-9.10opt, include auto0 in access path.
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
+ # This would have no effect because the records in Pkg of these directories
+ # were from access as children of {$p(:1:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
+ 0 OK1 0 OK2}
+test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup {
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- \
+ $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
+ 0 1.2.3 0 2.3.4 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
+ 0 OK1 0 OK2}
+test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup {
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library]
+
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4]
+ set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5]
+
+ # Try to load the packages.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
+ set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
+
+ list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
+ $mappA -- $mappB
+} -cleanup {
+ safe::interpDelete $i
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\
+ 1 {* not found in access path} -- 1 1 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}}
+test safe-9.20 {check module loading} -setup {
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} -- res0 res1 res2}
+# - The command safe::InterpSetConfig adds the master's [tcl::tm::list] in
+# tokenized form to the slave's access path, and then adds all the
+# descendants, discovered recursively by using glob.
+# - The order of the directories in the list returned by glob is system-dependent,
+# and therefore this is true also for (a) the order of token assignment to
+# descendants of the [tcl::tm::list] roots; and (b) the order of those same
+# directories in the access path. Both those things must be sorted before
+# comparing with expected results. The test is therefore not totally strict,
+# but will notice missing or surplus directories.
+test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup {
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Load pkg data.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup {
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup {
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Force the interpreter to acquire pkg data which will soon become stale.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Refresh stale pkg data.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup {
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Force the interpreter to acquire pkg data which will soon become stale.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
catch {teststaticpkg Safepkg1 0 0}
test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup {
@@ -412,7 +1167,7 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup {
interp eval $i {load {} Safepkg1}
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
+} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup {
set i [safe::interpCreate]
} -body {
@@ -421,7 +1176,7 @@ test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup {
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
-} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
invoked from within
"load {} Safepkg1"
invoked from within
@@ -444,7 +1199,7 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl
interp eval $i {interp create x; load {} Safepkg1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
+} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
set i [safe::interpCreate -nestedloadok]
catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o
@@ -452,7 +1207,7 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints T
} -returnCodes ok -cleanup {
unset -nocomplain m o
safe::interpDelete $i
-} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
invoked from within
"load {} Safepkg1 x"
invoked from within
@@ -612,6 +1367,15 @@ proc buildEnvironment {filename} {
set testdir2 [makeDirectory deletemetoo $testdir]
set testfile [makeFile {} $filename $testdir2]
}
+proc buildEnvironment2 {filename} {
+ upvar 1 testdir testdir testdir2 testdir2 testfile testfile
+ upvar 1 testdir3 testdir3 testfile2 testfile2
+ set testdir [makeDirectory deletethisdir]
+ set testdir2 [makeDirectory deletemetoo $testdir]
+ set testfile [makeFile {} $filename $testdir2]
+ set testdir3 [makeDirectory deleteme $testdir]
+ set testfile2 [makeFile {} $filename $testdir3]
+}
#### New tests for Safe base glob, with patches @ Bug 2964715
test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
set i [safe::interpCreate]
@@ -683,21 +1447,33 @@ test safe-13.6 {as 13.4 but test silent failure when result is outside access_pa
safe::interpDelete $i
removeDirectory $testdir
} -result {}
-test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup {
+test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug 2964715]} -setup {
set i [safe::interpCreate]
buildEnvironment pkgIndex.tcl
} -body {
set safeTD [::safe::interpAddToAccessPath $i $testdir]
::safe::interpAddToAccessPath $i $testdir2
- string map [list $safeTD EXPECTED] [$i eval [list \
+ mapList [list $safeTD EXPECTED] [$i eval [list \
+ glob -directory $safeTD -join * pkgIndex.tcl]]
+} -cleanup {
+ safe::interpDelete $i
+ removeDirectory $testdir
+} -result {EXPECTED/deletemetoo/pkgIndex.tcl}
+test safe-13.7.1 {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup {
+ set i [safe::interpCreate]
+ buildEnvironment2 pkgIndex.tcl
+} -body {
+ set safeTD [::safe::interpAddToAccessPath $i $testdir]
+ ::safe::interpAddToAccessPath $i $testdir2
+ ::safe::interpAddToAccessPath $i $testdir3
+ mapAndSortList [list $safeTD EXPECTED] [$i eval [list \
glob -directory $safeTD -join * pkgIndex.tcl]]
} -cleanup {
safe::interpDelete $i
removeDirectory $testdir
-} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}}
-# Note the extra {} around the result above; that's *expected* because of the
-# format of virtual path roots.
-test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup {
+} -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl}
+# See comments on lsort after test safe-9.20.
+test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup {
set i [safe::interpCreate]
buildEnvironment notIndex.tcl
} -body {
@@ -735,6 +1511,7 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p
removeDirectory $testdir
} -result {}
rename buildEnvironment {}
+rename buildEnvironment2 {}
#### Test for the module path
test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup {
@@ -765,7 +1542,7 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup {
unset -nocomplain msg
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
-test safe-15.1.1 {safe file ensemble does not surprise code} -setup {
+test safe-15.2 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
} -body {
set result [expr {"file" in [interp hidden $i]}]
@@ -799,6 +1576,7 @@ test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
} -cleanup {
safe::interpDelete $i
set env(HOME) $savedHOME
+ unset savedHOME
} -result {./~}
test safe-16.2 {Bug 3529949: defang ~user in paths} -setup {
set i [safe::interpCreate]
@@ -808,6 +1586,7 @@ test safe-16.2 {Bug 3529949: defang ~user in paths} -setup {
"file join \[file dirname ~$user\] \[file tail ~$user\]"]
} -cleanup {
safe::interpDelete $i
+ unset user
} -result {./~USER}
test safe-16.3 {Bug 3529949: defang ~ in globs} -setup {
set syntheticHOME [makeDirectory foo]
@@ -822,6 +1601,7 @@ test safe-16.3 {Bug 3529949: defang ~ in globs} -setup {
safe::interpDelete $i
set env(HOME) $savedHOME
removeDirectory $syntheticHOME
+ unset savedHOME syntheticHOME
} -result {}
test safe-16.4 {Bug 3529949: defang ~user in globs} -setup {
set i [safe::interpCreate]
@@ -831,9 +1611,58 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup {
} -cleanup {
safe::interpDelete $i
} -result {}
+test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup {
+ set savedHOME $env(HOME)
+ set env(HOME) /foo/bar
+ set i [safe::interpCreate]
+} -body {
+ $i eval {
+ set d [format %c 126]
+ file join {$p(:0:)} $d
+ }
+} -cleanup {
+ safe::interpDelete $i
+ set env(HOME) $savedHOME
+ unset savedHOME
+} -result {~}
+test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup {
+ set savedHOME $env(HOME)
+ set env(HOME) /foo/bar
+ set i [safe::interpCreate]
+} -body {
+ $i eval {
+ set d [format %c 126]
+ file join {$p(:0:)/foo/bar} $d
+ }
+} -cleanup {
+ safe::interpDelete $i
+ set env(HOME) $savedHOME
+ unset savedHOME
+} -result {~}
+test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup {
+ set i [safe::interpCreate]
+ set user $tcl_platform(user)
+} -body {
+ string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]]
+} -cleanup {
+ safe::interpDelete $i
+ unset user
+} -result {~USER}
+test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup {
+ set i [safe::interpCreate]
+ set user $tcl_platform(user)
+} -body {
+ string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]]
+} -cleanup {
+ safe::interpDelete $i
+ unset user
+} -result {~USER}
-set ::auto_path $saveAutoPath
# cleanup
+set ::auto_path $SaveAutoPath
+unset SaveAutoPath TestsDir PathMapp
+rename mapList {}
+rename mapAndSortList {}
::tcltest::cleanupTests
return