1673 lines
68 KiB
Plaintext
1673 lines
68 KiB
Plaintext
|
# safe.test --
|
|||
|
|
#
|
|||
|
|
# This file contains a collection of tests for safe Tcl, packages loading, and
|
|||
|
|
# 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-stock.test.
|
|||
|
|
#
|
|||
|
|
# 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.
|
|||
|
|
|
|||
|
|
if {"::tcltest" ni [namespace children]} {
|
|||
|
|
package require tcltest 2.5
|
|||
|
|
namespace import -force ::tcltest::*
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
foreach i [interp children] {
|
|||
|
|
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
|
|||
|
|
}
|
|||
|
|
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
|
|||
|
|
# 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}]}]
|
|||
|
|
|
|||
|
|
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
|
|||
|
|
safe::interpConfigure
|
|||
|
|
} -result {no value given for parameter "slave" (use -help for full usage) :
|
|||
|
|
slave name () name of the slave}
|
|||
|
|
test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body {
|
|||
|
|
safe::interpCreate -help
|
|||
|
|
} -result {Usage information:
|
|||
|
|
Var/FlagName Type Value Help
|
|||
|
|
------------ ---- ----- ----
|
|||
|
|
(-help gives this help)
|
|||
|
|
?slave? name () name of the slave (optional)
|
|||
|
|
-accessPath list () access path for the slave
|
|||
|
|
-noStatics boolflag (false) prevent loading of statically linked pkgs
|
|||
|
|
-statics boolean (true) loading of statically linked pkgs
|
|||
|
|
-nestedLoadOk boolflag (false) allow nested loading
|
|||
|
|
-nested boolean (false) nested loading
|
|||
|
|
-deleteHook script () delete hook}
|
|||
|
|
test safe-1.3 {safe::interpInit syntax} -returnCodes error -body {
|
|||
|
|
safe::interpInit -noStatics
|
|||
|
|
} -result {bad value "-noStatics" for parameter
|
|||
|
|
slave name () name of the slave}
|
|||
|
|
|
|||
|
|
test safe-2.1 {creating interpreters, should have no aliases} emptyTest {
|
|||
|
|
# Disabled this test. It tests nothing sensible. [Bug 999612]
|
|||
|
|
# interp aliases
|
|||
|
|
} ""
|
|||
|
|
test safe-2.2 {creating interpreters, should have no aliases} -setup {
|
|||
|
|
catch {safe::interpDelete a}
|
|||
|
|
} -body {
|
|||
|
|
interp create a
|
|||
|
|
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}
|
|||
|
|
} -body {
|
|||
|
|
interp create a -safe
|
|||
|
|
lsort [a aliases]
|
|||
|
|
} -cleanup {
|
|||
|
|
interp delete a
|
|||
|
|
} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock}
|
|||
|
|
|
|||
|
|
test safe-3.1 {calling safe::interpInit is safe} -setup {
|
|||
|
|
catch {safe::interpDelete a}
|
|||
|
|
interp create a -safe
|
|||
|
|
} -body {
|
|||
|
|
safe::interpInit a
|
|||
|
|
interp eval a exec ls
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete a
|
|||
|
|
} -result {invalid command name "exec"}
|
|||
|
|
test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
|
|||
|
|
catch {safe::interpDelete a}
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate a
|
|||
|
|
lsort [a aliases]
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete a
|
|||
|
|
} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source}
|
|||
|
|
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
|
|||
|
|
catch {safe::interpDelete a}
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate a
|
|||
|
|
interp eval a {source [file join $tcl_library init.tcl]}
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete a
|
|||
|
|
} -result ""
|
|||
|
|
test safe-3.4 {calling safe::interpCreate on trusted interp} -setup {
|
|||
|
|
catch {safe::interpDelete a}
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate a
|
|||
|
|
interp eval a {source [file join $tcl_library init.tcl]}
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete a
|
|||
|
|
} -result {}
|
|||
|
|
|
|||
|
|
test safe-4.1 {safe::interpDelete} -setup {
|
|||
|
|
catch {safe::interpDelete a}
|
|||
|
|
} -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}
|
|||
|
|
} -body {
|
|||
|
|
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}
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate a
|
|||
|
|
safe::interpCreate a
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete a
|
|||
|
|
} -result {interpreter named "a" already exists, cannot create}
|
|||
|
|
test safe-4.6 {safe::interpDelete, indirectly} -setup {
|
|||
|
|
catch {safe::interpDelete a}
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate a
|
|||
|
|
a eval exit
|
|||
|
|
} -result ""
|
|||
|
|
|
|||
|
|
# The old test "safe-5.1" has been moved to "safe-stock-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.
|
|||
|
|
|
|||
|
|
unset -nocomplain path
|
|||
|
|
|
|||
|
|
test safe-5.1 {example tclIndex commands, test in parent interpreter} -setup {
|
|||
|
|
set tmpAutoPath $::auto_path
|
|||
|
|
lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2]
|
|||
|
|
} -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 {0 ok1 0 ok2}
|
|||
|
|
test safe-5.2 {example tclIndex commands, negative test in parent 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 parent 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 parent 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 parent 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 parent 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} {
|
|||
|
|
# Helper procedure that ensures the safe interp is cleaned up even if
|
|||
|
|
# there is a failure in the script.
|
|||
|
|
set SafeInterp [interp create -safe]
|
|||
|
|
catch {$SafeInterp eval $script} msg opts
|
|||
|
|
interp delete $SafeInterp
|
|||
|
|
return -options $opts $msg
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
test safe-6.1 {test safe interpreters knowledge of the world} {
|
|||
|
|
lsort [SafeEval {info globals}]
|
|||
|
|
} {tcl_interactive tcl_patchLevel tcl_platform tcl_version}
|
|||
|
|
test safe-6.2 {test safe interpreters knowledge of the world} {
|
|||
|
|
SafeEval {info script}
|
|||
|
|
} {}
|
|||
|
|
test safe-6.3 {test safe interpreters knowledge of the world} {
|
|||
|
|
set r [SafeEval {array names tcl_platform}]
|
|||
|
|
# If running a windows-debug shell, remove the "debug" element from r.
|
|||
|
|
if {[testConstraint win]} {
|
|||
|
|
set r [lsearch -all -inline -not -exact $r "debug"]
|
|||
|
|
}
|
|||
|
|
set r [lsearch -all -inline -not -exact $r "threaded"]
|
|||
|
|
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
|
|||
|
|
# 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 child works like in the parent)
|
|||
|
|
set v [interp eval $i {package require SafeTestPackage1}]
|
|||
|
|
# no error shall occur:
|
|||
|
|
interp eval $i {HeresPackage1}
|
|||
|
|
set v
|
|||
|
|
} -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 p* (not p1 if parent has a module path)
|
|||
|
|
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
|
|||
|
|
# should add as p* (not p2 if parent 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 $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 children]
|
|||
|
|
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 $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 children]
|
|||
|
|
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 parent 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
|
|||
|
|
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}
|
|||
|
|
set prevlog [safe::setLogCmd]
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate $i
|
|||
|
|
safe::setLogCmd safe-test-log
|
|||
|
|
list [catch {$i eval {source .}} msg] $msg $log
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::setLogCmd $prevlog
|
|||
|
|
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}
|
|||
|
|
set prevlog [safe::setLogCmd]
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate $i
|
|||
|
|
safe::setLogCmd safe-test-log
|
|||
|
|
list [catch {$i eval {source /abc/def}} msg] $msg $log
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::setLogCmd $prevlog
|
|||
|
|
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}
|
|||
|
|
set prevlog [safe::setLogCmd]
|
|||
|
|
} -body {
|
|||
|
|
# This tested filename == *.tcl or tclIndex, but that restriction was
|
|||
|
|
# removed in 8.4a4 - hobbs
|
|||
|
|
safe::interpCreate $i
|
|||
|
|
safe::setLogCmd safe-test-log
|
|||
|
|
list [catch {
|
|||
|
|
$i eval {source [file join [info lib] blah]}
|
|||
|
|
} msg] $msg $log
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::setLogCmd $prevlog
|
|||
|
|
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}
|
|||
|
|
set prevlog [safe::setLogCmd]
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate $i
|
|||
|
|
safe::setLogCmd safe-test-log
|
|||
|
|
list [catch {
|
|||
|
|
$i eval {source [file join [info lib] blah.tcl]}
|
|||
|
|
} msg] $msg $log
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::setLogCmd $prevlog
|
|||
|
|
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}
|
|||
|
|
set prevlog [safe::setLogCmd]
|
|||
|
|
} -body {
|
|||
|
|
safe::interpCreate $i
|
|||
|
|
# This tested length of filename, but that restriction was removed in
|
|||
|
|
# 8.4a4 - hobbs
|
|||
|
|
safe::setLogCmd safe-test-log
|
|||
|
|
list [catch {
|
|||
|
|
$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}
|
|||
|
|
} msg] $msg $log
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::setLogCmd $prevlog
|
|||
|
|
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 {
|
|||
|
|
safe::interpCreate $i
|
|||
|
|
set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
|
|||
|
|
$i eval [list source $token/[file tail $returnScript]]
|
|||
|
|
} -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 {
|
|||
|
|
safe::interpCreate $i
|
|||
|
|
set token [safe::interpAddToAccessPath $i [file dirname $returnScript]]
|
|||
|
|
$i eval [list apply {filename {
|
|||
|
|
source $filename
|
|||
|
|
error boom
|
|||
|
|
}} $token/[file tail $returnScript]]
|
|||
|
|
} -cleanup {
|
|||
|
|
catch {safe::interpDelete $i}
|
|||
|
|
removeFile $returnScript
|
|||
|
|
unset i
|
|||
|
|
} -result ok
|
|||
|
|
|
|||
|
|
test safe-9.1 {safe interps' deleteHook} -setup {
|
|||
|
|
set i "a"
|
|||
|
|
catch {safe::interpDelete $i}
|
|||
|
|
set res {}
|
|||
|
|
} -body {
|
|||
|
|
proc testDelHook {args} {
|
|||
|
|
global res
|
|||
|
|
# the interp still exists at that point
|
|||
|
|
interp eval a {set delete 1}
|
|||
|
|
# mark that we've been here (successfully)
|
|||
|
|
set res $args
|
|||
|
|
}
|
|||
|
|
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 {}
|
|||
|
|
proc safe-test-log {str} {lappend ::log $str}
|
|||
|
|
set prevlog [safe::setLogCmd]
|
|||
|
|
} -body {
|
|||
|
|
proc testDelHook {args} {
|
|||
|
|
global res
|
|||
|
|
# the interp still exists at that point
|
|||
|
|
interp eval a {set delete 1}
|
|||
|
|
# mark that we've been here (successfully)
|
|||
|
|
set res $args
|
|||
|
|
# create an exception
|
|||
|
|
error "being catched"
|
|||
|
|
}
|
|||
|
|
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"
|
|||
|
|
safe::setLogCmd safe-test-log
|
|||
|
|
list [safe::interpDelete $i] $res $log
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::setLogCmd $prevlog
|
|||
|
|
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
|
|||
|
|
} -result {conflicting values given for -statics and -noStatics}
|
|||
|
|
test safe-9.4 {dual specification of statics} {
|
|||
|
|
# no error shall occur
|
|||
|
|
safe::interpDelete [safe::interpCreate -stat false -nostat]
|
|||
|
|
} {}
|
|||
|
|
test safe-9.5 {dual specification of nested} -returnCodes error -body {
|
|||
|
|
safe::interpCreate -nested 0 -nestedload
|
|||
|
|
} -result {conflicting values given for -nested and -nestedLoadOk}
|
|||
|
|
test safe-9.6 {interpConfigure widget like behaviour} -body {
|
|||
|
|
# this test shall work, don't try to "fix it" unless you *really* know what
|
|||
|
|
# you are doing (ie you are me :p) -- dl
|
|||
|
|
list [set i [safe::interpCreate \
|
|||
|
|
-noStatics \
|
|||
|
|
-nestedLoadOk \
|
|||
|
|
-deleteHook {foo bar}]
|
|||
|
|
safe::interpConfigure $i -accessPath /foo/bar
|
|||
|
|
safe::interpConfigure $i]\
|
|||
|
|
[safe::interpConfigure $i -aCCess]\
|
|||
|
|
[safe::interpConfigure $i -nested]\
|
|||
|
|
[safe::interpConfigure $i -statics]\
|
|||
|
|
[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}}
|
|||
|
|
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 parent's [tcl::tm::list] in
|
|||
|
|
# tokenized form to the child'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 {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i {load {} Safepkg1}
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -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 {
|
|||
|
|
catch {interp eval $i {load {} Safepkg1}} m o
|
|||
|
|
dict get $o -errorinfo
|
|||
|
|
} -returnCodes ok -cleanup {
|
|||
|
|
unset -nocomplain m o
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -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
|
|||
|
|
"interp eval $i {load {} Safepkg1}"}
|
|||
|
|
test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body {
|
|||
|
|
set i [safe::interpCreate -nostatics]
|
|||
|
|
interp eval $i {load {} Safepkg1}
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {permission denied (static package)}
|
|||
|
|
test safe-10.3 {testing nested statics loading / no nested by default} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -constraints TcltestPackage -body {
|
|||
|
|
interp eval $i {interp create x; load {} Safepkg1 x}
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {permission denied (nested load)}
|
|||
|
|
test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
|
|||
|
|
set i [safe::interpCreate -nestedloadok]
|
|||
|
|
interp eval $i {interp create x; load {} Safepkg1 x}
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -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
|
|||
|
|
dict get $o -errorinfo
|
|||
|
|
} -returnCodes ok -cleanup {
|
|||
|
|
unset -nocomplain m o
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -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
|
|||
|
|
"interp eval $i {interp create x; load {} Safepkg1 x}"}
|
|||
|
|
|
|||
|
|
test safe-11.1 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {wrong # args: should be "encoding option ?arg ...?"}
|
|||
|
|
test safe-11.1a {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding foobar
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -match glob -result {bad option "foobar": must be *}
|
|||
|
|
test safe-11.2 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding system cp775
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {wrong # args: should be "encoding system"}
|
|||
|
|
test safe-11.3 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding system
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result [encoding system]
|
|||
|
|
test safe-11.4 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding names
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result [encoding names]
|
|||
|
|
test safe-11.5 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding convertfrom cp1258 foobar
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result foobar
|
|||
|
|
test safe-11.6 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding convertto cp1258 foobar
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result foobar
|
|||
|
|
test safe-11.7 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding convertfrom
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"}
|
|||
|
|
test safe-11.7.1 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
catch {interp eval $i encoding convertfrom} m o
|
|||
|
|
dict get $o -errorinfo
|
|||
|
|
} -returnCodes ok -match glob -cleanup {
|
|||
|
|
unset -nocomplain m o
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"
|
|||
|
|
while executing
|
|||
|
|
"encoding convertfrom"
|
|||
|
|
invoked from within
|
|||
|
|
"::interp invokehidden interp* encoding convertfrom"
|
|||
|
|
invoked from within
|
|||
|
|
"encoding convertfrom"
|
|||
|
|
invoked from within
|
|||
|
|
"interp eval $i encoding convertfrom"}
|
|||
|
|
test safe-11.8 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
interp eval $i encoding convertto
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {wrong # args: should be "encoding convertto ?encoding? data"}
|
|||
|
|
test safe-11.8.1 {testing safe encoding} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
catch {interp eval $i encoding convertto} m o
|
|||
|
|
dict get $o -errorinfo
|
|||
|
|
} -returnCodes ok -match glob -cleanup {
|
|||
|
|
unset -nocomplain m o
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {wrong # args: should be "encoding convertto ?encoding? data"
|
|||
|
|
while executing
|
|||
|
|
"encoding convertto"
|
|||
|
|
invoked from within
|
|||
|
|
"::interp invokehidden interp* encoding convertto"
|
|||
|
|
invoked from within
|
|||
|
|
"encoding convertto"
|
|||
|
|
invoked from within
|
|||
|
|
"interp eval $i encoding convertto"}
|
|||
|
|
|
|||
|
|
test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob ../*
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result "permission denied"
|
|||
|
|
test safe-12.2 {glob is restricted [Bug 2906841]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob -directory .. *
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result "permission denied"
|
|||
|
|
test safe-12.3 {glob is restricted [Bug 2906841]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob -join .. *
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result "permission denied"
|
|||
|
|
test safe-12.4 {glob is restricted [Bug 2906841]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob -nocomplain ../*
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {}
|
|||
|
|
test safe-12.5 {glob is restricted [Bug 2906841]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob -directory .. -nocomplain *
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {}
|
|||
|
|
test safe-12.6 {glob is restricted [Bug 2906841]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob -nocomplain -join .. *
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {}
|
|||
|
|
test safe-12.7 {glob is restricted} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob *
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {permission denied}
|
|||
|
|
|
|||
|
|
proc buildEnvironment {filename} {
|
|||
|
|
upvar 1 testdir testdir testdir2 testdir2 testfile testfile
|
|||
|
|
set testdir [makeDirectory deletethisdir]
|
|||
|
|
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]
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob *
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result {permission denied}
|
|||
|
|
test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
buildEnvironment deleteme.tm
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir2
|
|||
|
|
set result [$i eval glob -nocomplain -directory $testdir2 *.tm]
|
|||
|
|
if {$result eq [list $testfile]} {
|
|||
|
|
return "glob match"
|
|||
|
|
} else {
|
|||
|
|
return "no match: $result"
|
|||
|
|
}
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
removeDirectory $testdir
|
|||
|
|
} -result {glob match}
|
|||
|
|
test safe-13.3 {cf 13.2 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
buildEnvironment deleteme.tm
|
|||
|
|
} -body {
|
|||
|
|
$i eval glob -directory $testdir2 *.tm
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
removeDirectory $testdir
|
|||
|
|
} -result {permission denied}
|
|||
|
|
test safe-13.4 {another valid glob call [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
buildEnvironment deleteme.tm
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir2
|
|||
|
|
set result [$i eval \
|
|||
|
|
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]]
|
|||
|
|
if {$result eq [list $testfile]} {
|
|||
|
|
return "glob match"
|
|||
|
|
} else {
|
|||
|
|
return "no match: $result"
|
|||
|
|
}
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
removeDirectory $testdir
|
|||
|
|
} -result {glob match}
|
|||
|
|
test safe-13.5 {as 13.4 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
buildEnvironment deleteme.tm
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir2
|
|||
|
|
$i eval \
|
|||
|
|
glob -directory $testdir [file join deletemetoo *.tm]
|
|||
|
|
} -returnCodes error -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
removeDirectory $testdir
|
|||
|
|
} -result {permission denied}
|
|||
|
|
test safe-13.6 {as 13.4 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
buildEnvironment deleteme.tm
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir
|
|||
|
|
$i eval \
|
|||
|
|
glob -nocomplain -directory $testdir [file join deletemetoo *.tm]
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
removeDirectory $testdir
|
|||
|
|
} -result {}
|
|||
|
|
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
|
|||
|
|
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/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 {
|
|||
|
|
set safeTD [::safe::interpAddToAccessPath $i $testdir]
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir2
|
|||
|
|
$i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl]
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
removeDirectory $testdir
|
|||
|
|
} -result {}
|
|||
|
|
test safe-13.9 {as 13.8 but test glob failure when -directory is outside access path [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
buildEnvironment notIndex.tcl
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir2
|
|||
|
|
set result [$i eval \
|
|||
|
|
glob -directory $testdir -join -nocomplain * notIndex.tcl]
|
|||
|
|
if {$result eq [list $testfile]} {
|
|||
|
|
return {glob match}
|
|||
|
|
} else {
|
|||
|
|
return "no match: $result"
|
|||
|
|
}
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
removeDirectory $testdir
|
|||
|
|
} -result {no match: }
|
|||
|
|
test safe-13.10 {as 13.8 but test silent failure when result is outside access_path [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
buildEnvironment notIndex.tcl
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $testdir
|
|||
|
|
$i eval glob -directory $testdir -join -nocomplain * notIndex.tcl
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
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 parent interpreter [Bug 2964715]} -setup {
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
set tm {}
|
|||
|
|
foreach token [$i eval ::tcl::tm::path list] {
|
|||
|
|
lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token]
|
|||
|
|
}
|
|||
|
|
return $tm
|
|||
|
|
} -cleanup {
|
|||
|
|
safe::interpDelete $i
|
|||
|
|
} -result [::tcl::tm::path list]
|
|||
|
|
|
|||
|
|
test safe-15.1 {safe file ensemble does not surprise code} -setup {
|
|||
|
|
set i [interp create -safe]
|
|||
|
|
} -body {
|
|||
|
|
set result [expr {"file" in [interp hidden $i]}]
|
|||
|
|
lappend result [interp eval $i {tcl::file::split a/b/c}]
|
|||
|
|
lappend result [catch {interp eval $i {tcl::file::isdirectory .}}]
|
|||
|
|
lappend result [interp invokehidden $i file split a/b/c]
|
|||
|
|
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
|
|||
|
|
lappend result [catch {interp invokehidden $i file isdirectory .}]
|
|||
|
|
interp expose $i file
|
|||
|
|
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
|
|||
|
|
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
|
|||
|
|
} -cleanup {
|
|||
|
|
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.2 {safe file ensemble does not surprise code} -setup {
|
|||
|
|
set i [interp create -safe]
|
|||
|
|
} -body {
|
|||
|
|
set result [expr {"file" in [interp hidden $i]}]
|
|||
|
|
lappend result [interp eval $i {tcl::file::split a/b/c}]
|
|||
|
|
lappend result [catch {interp eval $i {tcl::file::isdirectory .}}]
|
|||
|
|
lappend result [interp invokehidden $i file split a/b/c]
|
|||
|
|
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
|
|||
|
|
lappend result [catch {interp invokehidden $i file isdirectory .}]
|
|||
|
|
interp expose $i file
|
|||
|
|
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
|
|||
|
|
lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo]
|
|||
|
|
} -cleanup {
|
|||
|
|
unset -nocomplain msg o
|
|||
|
|
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
|
|||
|
|
while executing
|
|||
|
|
"file isdirectory ."
|
|||
|
|
invoked from within
|
|||
|
|
"interp eval $i {file isdirectory .}"}}
|
|||
|
|
|
|||
|
|
### ~ should have no special meaning in paths in safe interpreters
|
|||
|
|
test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
|
|||
|
|
set savedHOME $env(HOME)
|
|||
|
|
set env(HOME) /foo/bar
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
$i eval {
|
|||
|
|
set d [format %c 126]
|
|||
|
|
list [file join [file dirname $d] [file tail $d]]
|
|||
|
|
}
|
|||
|
|
} -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]
|
|||
|
|
set user $tcl_platform(user)
|
|||
|
|
} -body {
|
|||
|
|
string map [list $user USER] [$i eval \
|
|||
|
|
"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]
|
|||
|
|
makeFile {} bar $syntheticHOME
|
|||
|
|
set savedHOME $env(HOME)
|
|||
|
|
set env(HOME) $syntheticHOME
|
|||
|
|
set i [safe::interpCreate]
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $syntheticHOME
|
|||
|
|
$i eval {glob -nocomplain ~/*}
|
|||
|
|
} -cleanup {
|
|||
|
|
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]
|
|||
|
|
} -body {
|
|||
|
|
::safe::interpAddToAccessPath $i $~$tcl_platform(user)
|
|||
|
|
$i eval [list glob -nocomplain ~$tcl_platform(user)/*]
|
|||
|
|
} -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}
|
|||
|
|
|
|||
|
|
# cleanup
|
|||
|
|
set ::auto_path $SaveAutoPath
|
|||
|
|
unset SaveAutoPath TestsDir PathMapp
|
|||
|
|
unset -nocomplain path
|
|||
|
|
rename mapList {}
|
|||
|
|
rename mapAndSortList {}
|
|||
|
|
::tcltest::cleanupTests
|
|||
|
|
return
|
|||
|
|
|
|||
|
|
# Local Variables:
|
|||
|
|
# mode: tcl
|
|||
|
|
# End:
|