riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/tests/safe.test

1673 lines
68 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# 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:
Reference in New Issue View Git Blame Copy Permalink