diff options
Diffstat (limited to 'tests/safe.test')
| -rw-r--r-- | tests/safe.test | 435 |
1 files changed, 329 insertions, 106 deletions
diff --git a/tests/safe.test b/tests/safe.test index a3def0a..8879518 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,13 +10,15 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +package require Tcl 8.5 + if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } foreach i [interp slaves] { - interp delete $i + interp delete $i } set saveAutoPath $::auto_path @@ -28,12 +30,11 @@ set ::auto_path [info library] catch {safe::interpConfigure} proc equiv {x} {return $x} - + test safe-1.1 {safe::interpConfigure syntax} { list [catch {safe::interpConfigure} msg] $msg; } {1 {no value given for parameter "slave" (use -help for full usage) : slave name () name of the slave}} - test safe-1.2 {safe::interpCreate syntax} { list [catch {safe::interpCreate -help} msg] $msg; } {1 {Usage information: @@ -47,15 +48,15 @@ test safe-1.2 {safe::interpCreate syntax} { -nestedLoadOk boolflag (false) allow nested loading -nested boolean (false) nested loading -deleteHook script () delete hook}} - test safe-1.3 {safe::interpInit syntax} { list [catch {safe::interpInit -noStatics} msg] $msg; } {1 {bad value "-noStatics" for parameter slave name () name of the slave}} -test safe-2.1 {creating interpreters, should have no aliases} { - interp aliases +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} { catch {safe::interpDelete a} @@ -64,13 +65,13 @@ test safe-2.2 {creating interpreters, should have no aliases} { safe::interpDelete a set l } "" -test safe-2.3 {creating safe interpreters, should have no aliases} { +test safe-2.3 {creating safe interpreters, should have no unexpected aliases} { catch {safe::interpDelete a} interp create a -safe set l [a aliases] interp delete a - set l -} "" + lsort $l +} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} test safe-3.1 {calling safe::interpInit is safe} { catch {safe::interpDelete a} @@ -86,7 +87,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} { set l [lsort [a aliases]] safe::interpDelete a set l -} {encoding exit file load source} +} {::tcl::info::nameofexecutable clock encoding exit file glob load source} test safe-3.3 {calling safe::interpCreate on trusted interp} { catch {safe::interpDelete a} safe::interpCreate a @@ -114,25 +115,6 @@ test safe-4.2 {safe::interpDelete, indirectly} { a alias exit safe::interpDelete a a eval exit } "" -test safe-4.3 {safe::interpDelete, state array (not a public api)} { - catch {safe::interpDelete a} - namespace eval safe {set [InterpStateName a](foo) 33} - # not an error anymore to call it if interp is already - # deleted, to make trhings smooth if it's called twice... - catch {safe::interpDelete a} m1 - catch {namespace eval safe {set [InterpStateName a](foo)}} m2 - list $m1 $m2 -} "{}\ - {can't read \"[safe::InterpStateName a](foo)\": no such variable}" - - -test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} { - catch {safe::interpDelete a} - safe::interpCreate a - namespace eval safe {set [InterpStateName a](foo) 33} - a eval exit - catch {namespace eval safe {set [InterpStateName a](foo)}} msg -} 1 test safe-4.5 {safe::interpDelete} { catch {safe::interpDelete a} @@ -158,43 +140,33 @@ test safe-5.1 {test auto-loading in safe interpreters} { } {0 -1} # test safe interps 'information leak' -proc SI {} { - global I - set I [interp create -safe]; -} -proc DI {} { - global I; - interp delete $I; +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} { - SI; set r [lsort [$I eval {info globals}]]; DI; set r + lsort [SafeEval {info globals}] } {tcl_interactive tcl_patchLevel tcl_platform tcl_version} test safe-6.2 {test safe interpreters knowledge of the world} { - SI; set r [$I eval {info script}]; DI; set r + SafeEval {info script} } {} test safe-6.3 {test safe interpreters knowledge of the world} { - SI - set r [lsort [$I eval {array names tcl_platform}]] - DI + set r [lsort [SafeEval {array names tcl_platform}]] # If running a windows-debug shell, remove the "debug" element from r. - if {$tcl_platform(platform) == "windows" && \ - [lsearch $r "debug"] != -1} { + if {[testConstraint win] && ("debug" in $r)} { set r [lreplace $r 1 1] } set threaded [lsearch $r "threaded"] if {$threaded != -1} { set r [lreplace $r $threaded $threaded] } - set tip [lsearch $r "tip,268"] - if {$tip != -1} { - set r [lreplace $r $tip $tip] - } - set tip [lsearch $r "tip,280"] - if {$tip != -1} { - set r [lreplace $r $tip $tip] - } set r -} {byteOrder platform wordSize} +} {byteOrder platform pointerSize wordSize} # more test should be added to check that hostname, nameofexecutable, # aren't leaking infos, but they still do... @@ -211,8 +183,7 @@ test safe-7.1 {tests that everything works at high level} { safe::interpDelete $i set v } 1.0 - -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} { +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]; # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] @@ -224,7 +195,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} { [catch {interp eval $i {package require http 1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] -} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" # test source control on file name @@ -235,9 +206,7 @@ test safe-8.1 {safe source control on file} { list [catch {$i eval {source}} msg] \ $msg \ [safe::interpDelete $i] ; -} {1 {wrong # args: should be "source fileName"} {}} - -# test source control on file name +} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} test safe-8.2 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -245,8 +214,7 @@ test safe-8.2 {safe source control on file} { list [catch {$i eval {source}} msg] \ $msg \ [safe::interpDelete $i] ; -} {1 {wrong # args: should be "source fileName"} {}} - +} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} test safe-8.3 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -261,8 +229,6 @@ test safe-8.3 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}} - - test safe-8.4 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -277,8 +243,6 @@ test safe-8.4 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}} - - test safe-8.5 {safe source control on file} { # This tested filename == *.tcl or tclIndex, but that restriction # was removed in 8.4a4 - hobbs @@ -295,8 +259,6 @@ test safe-8.5 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } [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} { set i "a"; catch {safe::interpDelete $i} @@ -311,8 +273,6 @@ test safe-8.6 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } [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} { # This tested length of filename, but that restriction # was removed in 8.4a4 - hobbs @@ -330,7 +290,6 @@ test safe-8.7 {safe source control on file} { [safe::setLogCmd $prevlog; unset log] \ [safe::interpDelete $i] ; } [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} { set i "a"; catch {safe::interpDelete $i} @@ -338,8 +297,32 @@ test safe-8.8 {safe source forbids -rsrc} { list [catch {$i eval {source -rsrc Init}} msg] \ $msg \ [safe::interpDelete $i] ; -} {1 {wrong # args: should be "source fileName"} {}} - +} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} +test safe-8.9 {safe source and return} -setup { + 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 +} -result ok +test safe-8.10 {safe source and return} -setup { + 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 +} -result ok test safe-9.1 {safe interps' deleteHook} { set i "a"; @@ -355,7 +338,6 @@ test safe-9.1 {safe interps' deleteHook} { safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; list [interp eval $i exit] $res } {{} {arg1 arg2 a}} - test safe-9.2 {safe interps' error in deleteHook} { set i "a"; catch {safe::interpDelete $i} @@ -378,22 +360,18 @@ test safe-9.2 {safe interps' error in deleteHook} { $log \ [safe::setLogCmd $prevlog; unset log]; } {{} {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} { list [catch {safe::interpCreate -stat true -nostat} msg] $msg } {1 {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} { list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg } {1 {conflicting values given for -nested and -nestedLoadOk}} -test safe-9.6 {interpConfigure widget like behaviour} { +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 \ @@ -410,47 +388,40 @@ test safe-9.6 {interpConfigure widget like behaviour} { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0; safe::interpConfigure $i] -} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}} - +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} # testing that nested and statics do what is advertised # (we use a static package : Tcltest) if {[catch {package require Tcltest} msg]} { - puts "This application hasn't been compiled with Tcltest" - puts "skipping remining safe test that relies on it." + testConstraint TcltestPackage 0 } else { - + testConstraint TcltestPackage 1 # we use the Tcltest package , which has no Safe_Init +} -test safe-10.1 {testing statics loading} { +test safe-10.1 {testing statics loading} TcltestPackage { set i [safe::interpCreate] list \ [catch {interp eval $i {load {} Tcltest}} msg] \ $msg \ [safe::interpDelete $i]; } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} - -test safe-10.2 {testing statics loading / -nostatics} { +test safe-10.2 {testing statics loading / -nostatics} TcltestPackage { set i [safe::interpCreate -nostatics] list \ [catch {interp eval $i {load {} Tcltest}} msg] \ $msg \ [safe::interpDelete $i]; } {1 {permission denied (static package)} {}} - - - -test safe-10.3 {testing nested statics loading / no nested by default} { +test safe-10.3 {testing nested statics loading / no nested by default} TcltestPackage { set i [safe::interpCreate] list \ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ $msg \ [safe::interpDelete $i]; } {1 {permission denied (nested load)} {}} - - -test safe-10.4 {testing nested statics loading / -nestedloadok} { +test safe-10.4 {testing nested statics loading / -nestedloadok} TcltestPackage { set i [safe::interpCreate -nestedloadok] list \ [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ @@ -458,17 +429,13 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} { [safe::interpDelete $i]; } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} - -} - test safe-11.1 {testing safe encoding} { set i [safe::interpCreate] list \ [catch {interp eval $i encoding} msg] \ $msg \ [safe::interpDelete $i]; -} {1 {wrong # args: should be "encoding option ?arg ...?"} {}} - +} {1 {wrong # args: should be "encoding option ..."} {}} test safe-11.2 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -476,7 +443,6 @@ test safe-11.2 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding system"} {}} - test safe-11.3 {testing safe encoding} { set i [safe::interpCreate] set result [catch { @@ -484,7 +450,6 @@ test safe-11.3 {testing safe encoding} { } msg] list $result $msg [safe::interpDelete $i] } {0 1 {}} - test safe-11.4 {testing safe encoding} { set i [safe::interpCreate] set result [catch { @@ -492,7 +457,6 @@ test safe-11.4 {testing safe encoding} { } msg] list $result $msg [safe::interpDelete $i] } {0 1 {}} - test safe-11.5 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -500,8 +464,6 @@ test safe-11.5 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {0 foobar {}} - - test safe-11.6 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -509,7 +471,6 @@ test safe-11.6 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {0 foobar {}} - test safe-11.7 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -517,8 +478,6 @@ test safe-11.7 {testing safe encoding} { $msg \ [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding convertfrom ?encoding? data"} {}} - - test safe-11.8 {testing safe encoding} { set i [safe::interpCreate] list \ @@ -527,7 +486,271 @@ test safe-11.8 {testing safe encoding} { [safe::interpDelete $i]; } {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}} +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 {} +proc mkfile {filename} { + close [open $filename w] +} +#### 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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + $i eval glob -directory $testdir2 *.tm +} -returnCodes error -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {permission denied} +test safe-13.4 {another valid glob call [Bug 2964715]} -setup { + set i [safe::interpCreate] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + $i eval \ + glob -directory $testdir [file join deletemetoo *.tm] +} -returnCodes error -cleanup { + safe::interpDelete $i + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 deleteme.tm] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval \ + glob -nocomplain -directory $testdir [file join deletemetoo *.tm] +} -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {} +test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup { + set i [safe::interpCreate] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 pkgIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + string map [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]] +} -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} +# Note the extra {} around the result above; that's *expected* because of the +# format of virtual path roots. +test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup { + set i [safe::interpCreate] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -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 + file delete -force $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] + set testdir [file join [temporaryDirectory] deletethisdir] + set testdir2 [file join $testdir deletemetoo] + set testfile [file join $testdir2 notIndex.tcl] + file mkdir $testdir2 + mkfile $testfile +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl +} -cleanup { + safe::interpDelete $i + file delete -force $testdir +} -result {} +rename mkfile {} + +#### Test for the module path +test safe-14.1 {Check that module path is the same as in the master 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] + +### ~ should have no special meaning in paths in safe interpreters +test safe-15.1 {Bug 2913625: defang ~ in paths} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -constraints knownBug -body { + $i eval { + set d [format %c 126] + list [file dirname $d] [file tail $d] \ + [file join [file dirname $d] [file tail $d]] + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME +} -result {~} +test safe-15.2 {Bug 2913625: defang ~user in paths} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -constraints knownBug -body { + string map [list $user USER] [$i eval \ + "file join \[file dirname ~$user\] \[file tail ~$user\]"] +} -cleanup { + safe::interpDelete $i +} -result {~USER} +test safe-15.3 {Bug 2913625: defang ~ in globs} -setup { + set savedHOME $env(HOME) + set env(HOME) / + set i [safe::interpCreate] +} -constraints knownBug -body { + $i expose glob realglob + $i eval {realglob -nocomplain [join {~ / *} ""]} +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME +} -result {~} +test safe-15.4 {Bug 2913625: defang ~user in globs} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -constraints knownBug -body { + $i expose glob realglob + string map [list $user USER] [$i eval [list\ + realglob -directory ~$user *]] +} -cleanup { + safe::interpDelete $i +} -result {~USER} + set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests |