Attachment "patch-to--core-8-5-branch--a4511ae802abe16609824d823fb247077e75f633.patch" to
ticket [2964719fff]
added by
kjnash
2012-06-04 02:48:25.
Index: library/init.tcl
==================================================================
--- library/init.tcl
+++ library/init.tcl
@@ -36,32 +36,35 @@
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
if {![info exists auto_path]} {
- if {[info exists env(TCLLIBPATH)]} {
+ if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
variable Dir
- foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
+
+ if {![interp issafe]} {
+ foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
+ if {$Dir ni $::auto_path} {
+ lappend ::auto_path $Dir
+ }
+ }
+ set Dir [file join [file dirname [file dirname \
+ [info nameofexecutable]]] lib]
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
- }
- set Dir [file join [file dirname [file dirname \
- [info nameofexecutable]]] lib]
- if {$Dir ni $::auto_path} {
- lappend ::auto_path $Dir
- }
- catch {
- foreach Dir $::tcl_pkgPath {
- if {$Dir ni $::auto_path} {
- lappend ::auto_path $Dir
+ catch {
+ foreach Dir $::tcl_pkgPath {
+ if {$Dir ni $::auto_path} {
+ lappend ::auto_path $Dir
+ }
}
}
}
if {![interp issafe]} {
Index: library/safe.tcl
==================================================================
--- library/safe.tcl
+++ library/safe.tcl
@@ -239,14 +239,15 @@
# Returns the slave name.
#
# Optional Arguments :
# + slave name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
-# if empty: the master auto_path will be used.
+# if empty: the master auto_path and its subdirectories will be
+# used.
# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
# if 1 :static packages are ok.
-# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
+# + nestedok : flag, if 0 :no loading to sub-sub interps (load xx xx sub)
# if 1 : multiple levels are ok.
# use the full name and no indent so auto_mkIndex can find us
proc ::safe::InterpCreate {
slave
@@ -268,16 +269,20 @@
InterpInit $slave $access_path $staticsok $nestedok $deletehook
}
#
# InterpSetConfig (was setAccessPath) :
-# Sets up slave virtual auto_path and corresponding structure within
+# Sets up slave virtual access 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.
+#
+# It is the caller's responsibility, if it supplies a non-empty value for
+# access_path, to make the first directory in the path suitable for use as
+# tcl_library, and (if ![SetAutoPathSync]), to set the slave's ::auto_path.
proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} {
global auto_path
# determine and store the access path if empty
@@ -298,15 +303,19 @@
[lreplace $access_path $where $where] \
0 [info library]]
Log $slave "tcl_libray was not in first in auto_path,\
moved it to front of slave's access_path" NOTICE
}
+
+ set raw_auto_path $access_path
# 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).
set access_path [AddSubDirs $access_path]
+ } else {
+ set raw_auto_path {}
}
Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
@@ -333,11 +342,24 @@
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
incr i
}
+ # Set the slave auto_path.
+ # If [SetAutoPathSync], SyncAccessPath will overwrite this value with the
+ # full access path.
+ # If ![SetAutoPathSync], Safe Base code will not change this value.
+ set tokens_auto_path {}
+ foreach dir $raw_auto_path {
+ if {[dict exists $remap_access_path $dir]} {
+ lappend tokens_auto_path [dict get $remap_access_path $dir]
+ }
+ }
+ ::interp eval $slave [list set auto_path $tokens_auto_path]
+
set morepaths [::tcl::tm::list]
+ set firstpass 1
while {[llength $morepaths]} {
set addpaths $morepaths
set morepaths {}
foreach dir $addpaths {
@@ -351,11 +373,16 @@
lappend access_path $dir
lappend slave_access_path $token
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]
# Recursively find deeper paths which may contain
# modules. Required to handle modules with names like
@@ -362,10 +389,11 @@
# 'platform::shell', which translate into
# 'platform/shell-X.tm', i.e arbitrarily deep
# subdirectories.
lappend morepaths {*}[glob -nocomplain -directory $dir -type d *]
}
+ set firstpass 0
}
set state(access_path) $access_path
set state(access_path,map) $map_access_path
set state(access_path,remap) $remap_access_path
@@ -525,10 +553,19 @@
proc ::safe::interpDelete {slave} {
Log $slave "About to delete" NOTICE
namespace upvar ::safe S$slave state
+
+ # Sub interpreters would be deleted automatically, but if they are managed
+ # by the Safe Base we also need to clean up, and this needs to be done
+ # independently of the cleanupHook.
+ foreach sub [interp slaves $slave] {
+ if {[info exists ::safe::S[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
# not been registered with us at all
@@ -592,24 +629,27 @@
}
# ------------------- 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 its recorded access path. Also sets
+# tcl_library to the first token of the access path.
#
proc ::safe::SyncAccessPath {slave} {
+ variable AutoPathSync
namespace upvar ::safe S$slave state
set slave_access_path $state(access_path,slave)
- ::interp eval $slave [list set auto_path $slave_access_path]
+ if {$AutoPathSync} {
+ ::interp eval $slave [list set auto_path $slave_access_path]
- Log $slave "auto_path in $slave has been set to $slave_access_path"\
- NOTICE
+ Log $slave "auto_path in $slave has been set to $slave_access_path"\
+ NOTICE
+ }
# This code assumes that info library is the first element in the
- # list of auto_path's. See -> InterpSetConfig for the code which
+ # list of access path's. See -> InterpSetConfig for the code which
# ensures this condition.
::interp eval $slave [list \
set tcl_library [lindex $slave_access_path 0]]
}
@@ -657,10 +697,11 @@
}
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
proc ::safe::AliasGlob {slave args} {
+ variable AutoPathSync
Log $slave "GLOB ! $args" NOTICE
set cmd {}
set at 0
array set got {
-directory 0
@@ -679,14 +720,18 @@
set dir {}
set virtualdir {}
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
}
@@ -698,19 +743,24 @@
set got($opt) 1
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"
+ if {$AutoPathSync} {
+ # 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"
+ } else {
+ break
+ }
}
-* {
Log $slave "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
+ # unsafe/unnecessary options rejected: -path
}
default {
break
}
}
@@ -732,11 +782,11 @@
return -code error "permission denied"
}
lappend cmd -directory $dir
}
- # Apply the -join semantics ourselves
+ # Apply the -join semantics ourselves (hence -join not copied to $cmd)
if {$got(-join)} {
set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
}
# Process remaining pattern arguments
@@ -1096,13 +1146,54 @@
# Log eventually.
# To enable error logging, set Log to {puts stderr} for instance,
# via setLogCmd.
return
}
+
+# Accessor method for ::safe::SetAutoPathSync
+# Usage: ::safe::SetAutoPathSync ?newValue?
+
+proc ::safe::SetAutoPathSync {args} {
+ variable AutoPathSync
+
+ if {[llength $args] == 1} {
+ set newValue [lindex $args 0]
+ if {![string is boolean -strict $newValue]} {
+ return -code error "new value must be a valid boolean"
+ }
+ set args [expr {$newValue && $newValue}]
+ if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
+ return -code error \
+ "cannot change AutoPathSync while Safe Base slaves exist"
+ }
+ }
+
+ set AutoPathSync {*}$args
+}
namespace eval ::safe {
- # internal variables
+ # internal variables (must not begin with "S")
+
+ # AutoPathSync
+ #
+ # Set AutoPathSync to 0 to give a slave's ::auto_path the same meaning as
+ # for an unsafe interpreter: the package command will search its directories
+ # and first-level subdirectories for pkgIndex.tcl files; the auto-loader
+ # will search its directories for tclIndex files. The access path and
+ # module path will be maintained as separate values, and ::auto_path will
+ # not be updated when the user calls ::safe::interpAddToAccessPath to add to
+ # the access path. If the user specifies an access path when calling
+ # interpCreate, interpInit or interpConfigure, it is the user's
+ # responsibility to define the slave's auto_path. If these commands are
+ # called with no (or empty) access path, the slave's auto_path will be set
+ # to a tokenized form of the master's auto_path, and these directories and
+ # their first-level subdirectories will be added to the access path.
+ #
+ # Set to 1 for "traditional" behavior: a slave's entire access path and
+ # module path are copied to its ::auto_path, which is updated whenever
+ # the user calls ::safe::interpAddToAccessPath to add to the access path.
+ variable AutoPathSync 1
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
variable Log {}
# The package maintains a state array per slave interp under its
Index: tests/safe.test
==================================================================
--- tests/safe.test
+++ tests/safe.test
@@ -15,10 +15,12 @@
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+testConstraint AutoSyncDefined 1
+
foreach i [interp slaves] {
interp delete $i
}
set saveAutoPath $::auto_path
@@ -170,35 +172,127 @@
# 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} {
- set i [safe::interpCreate];
+test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 1
+ }
+
+ set i [safe::interpCreate]
+
+} -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 1}]
# no error shall occur:
- interp eval $i {http_config};
- safe::interpDelete $i
+ interp eval $i {http_config}
set v
-} 1.0
-test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
- set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -result 1.0
+
+test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 1
+ } else {
+ set SyncVal_TMP 1
+ }
+} -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"];
+ # 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
# provided deep path)
list $token1 $token2 \
[catch {interp eval $i {package require http 1}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
+} -cleanup {
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
} -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 {}} {}"
+test safe-7.3 {check that safe subinterpreters work} {
+ set i [safe::interpCreate]
+ set j [safe::interpCreate [list $i x]]
+ list [interp slaves $i] [interp slaves $j] [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $i] [interp exists $j] [info vars ::safe::S$i] [info vars ::safe::S$j]
+} {x {} ok {} 0 0 {} {}}
+
+test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 1
+ } else {
+ set SyncVal_TMP 1
+ }
+} -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 [info library] http1.0]]
+ # this time, unlike test safe-7.2, http 1.0 should be found
+ list $token1 $token2 \
+ [catch {interp eval $i {package require http 1}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [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 {
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}"
+
+test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 1
+ }
+
+ set i [safe::interpCreate]
+
+ interp eval $i {
+ package forget platform::shell
+ package forget platform
+ catch {namespace delete ::platform}
+ }
+} -body {
+ # Should raise an error (module ancestor directory issue)
+ set code1 [catch {interp eval $i {package require shell}} msg1]
+ # Should not raise an error
+ set code2 [catch {interp eval $i {package require platform::shell}} msg2]
+ return [list $code1 $msg1 $code2]
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -result {1 {can't find package shell} 0}
# test source control on file name
test safe-8.1 {safe source control on file} {
set i "a";
catch {safe::interpDelete $i}
@@ -372,10 +466,12 @@
[safe::interpConfigure $i -DEL]\
[safe::interpConfigure $i -accessPath /blah -statics 1;
safe::interpConfigure $i]\
[safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
safe::interpConfigure $i]
+} -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}}
# testing that nested and statics do what is advertised
# (we use a static package : Tcltest)
@@ -734,10 +830,253 @@
string map [list $user USER] [$i eval [list\
realglob -directory ~$user *]]
} -cleanup {
safe::interpDelete $i
} -result {~USER}
+
+### No tests numbered safe-16.1 etc.
+
+### 17. The first element in a slave's ::auto_path and access path must be [info library].
+
+test safe-17.1 {Check that first element of slave auto_path (and access path) is Tcl Library} -setup {
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib1 $lib2]
+
+ set i [safe::interpCreate]
+} -body {
+ set autoList {}
+ set token [lindex [$i eval set ::auto_path] 0]
+ set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
+ set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
+ return [list [lindex $accessList 0] $auto0]
+} -cleanup {
+ set ::auto_path $::auto_TMP
+ safe::interpDelete $i
+} -result [list [info library] [info library]]
+
+test safe-17.2 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master} -setup {
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib2 $lib1]
+ # Unexpected order, should be reversed in the slave
+
+ set i [safe::interpCreate]
+} -body {
+ set autoList {}
+ set token [lindex [$i eval set ::auto_path] 0]
+ set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
+ set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
+
+ return [list [lindex $accessList 0] $auto0]
+} -cleanup {
+ set ::auto_path $::auto_TMP
+ safe::interpDelete $i
+} -result [list [info library] [info library]]
+
+### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off.
+
+test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 0
+ } else {
+ error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined}
+ }
+
+ # Without AutoPathSync, we need a more complete auto_path, because the slave will use the same value.
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib1 $lib2]
+
+ set i [safe::interpCreate]
+} -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 1}]
+ # no error shall occur:
+ interp eval $i {http_config}
+ set v
+} -cleanup {
+ set ::auto_path $::auto_TMP
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -result 1.0
+
+test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 0
+ } else {
+ error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined}
+ }
+} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ set auto1 [interp eval $i {set ::auto_path}]
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+ # 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"]
+ # an error shall occur (http is not anymore in the secure 0-level
+ # provided deep path)
+ list $auto1 $token1 $token2 \
+ [catch {interp eval $i {package require http 1}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} -cleanup {
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -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 {}} {}"
+
+test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 0
+ } else {
+ error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined}
+ }
+
+ set i [safe::interpCreate]
+
+} -body {
+ # This file's header sets auto_path to a single directory [info library],
+ # which is the one required by Safe Base to be present & first in the list.
+
+ set ap {}
+ foreach token [$i eval set ::auto_path] {
+ lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token]
+ }
+ return $ap
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -result [set ::auto_path]
+
+test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 0
+ } else {
+ error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined}
+ }
+} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+
+ # should not have been set by Safe Base:
+ set auto1 [interp eval $i {set ::auto_path}]
+
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+
+ # 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 [info library] http1.0]]
+
+ # should not have been changed by Safe Base:
+ set auto2 [interp eval $i {set ::auto_path}]
+
+ # This time, unlike test safe-18.2 and the try above, http 1.0 should be found:
+ list $auto1 $auto2 $token1 $token2 \
+ [catch {interp eval $i {package require http 1}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} -cleanup {
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}"
+
+test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup {
+ # All ::safe commands are loaded at start of file.
+ set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}]
+
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::SetAutoPathSync]
+ safe::SetAutoPathSync 0
+ } else {
+ error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined}
+ }
+
+ set i [safe::interpCreate]
+
+ interp eval $i {
+ package forget platform::shell
+ package forget platform
+ catch {namespace delete ::platform}
+ }
+} -body {
+ # Should raise an error (tests module ancestor directory rule)
+ set code1 [catch {interp eval $i {package require shell}} msg1]
+ # Should not raise an error
+ set code2 [catch {interp eval $i {package require platform::shell}} msg2]
+ return [list $code1 $msg1 $code2]
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::SetAutoPathSync $SyncVal_TMP
+ }
+} -result {1 {can't find package shell} 0}
+
+### 19. Test tokenization of directories available to a slave.
+
+test safe-19.1 {Check that each directory of the default auto_path is a valid token} -setup {
+ set i [safe::interpCreate]
+} -body {
+ set badTokens {}
+ foreach dir [$i eval {set ::auto_path}] {
+ if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
+ # Match - OK - token has expected form
+ } else {
+ # No match - possibly an ordinary path has not been tokenized
+ lappend badTokens $dir
+ }
+ }
+ set badTokens
+} -cleanup {
+ safe::interpDelete $i
+} -result {}
+
+test safe-19.2 {Check that each directory of the module path is a valid token} -setup {
+ set i [safe::interpCreate]
+} -body {
+ set badTokens {}
+ foreach dir [$i eval {::tcl::tm::path list}] {
+ if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
+ # Match - OK - token has expected form
+ } else {
+ # No match - possibly an ordinary path has not been tokenized
+ lappend badTokens $dir
+ }
+ }
+ set badTokens
+} -cleanup {
+ safe::interpDelete $i
+} -result {}
+
set ::auto_path $saveAutoPath
# cleanup
::tcltest::cleanupTests
return
