Import Tcl 8.5.15 (as of svn r89086)
This commit is contained in:
Zachary Ware
757
tests/safe.test
Normal file
757
tests/safe.test
Normal file
@@ -0,0 +1,757 @@
|
||||
# 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.
|
||||
#
|
||||
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require Tcl 8.5
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
foreach i [interp slaves] {
|
||||
interp delete $i
|
||||
}
|
||||
|
||||
set saveAutoPath $::auto_path
|
||||
set ::auto_path [info library]
|
||||
|
||||
# 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}
|
||||
|
||||
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:
|
||||
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} {
|
||||
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} 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}
|
||||
interp create a
|
||||
set l [a aliases]
|
||||
safe::interpDelete a
|
||||
set l
|
||||
} ""
|
||||
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
|
||||
lsort $l
|
||||
} {::tcl::mathfunc::max ::tcl::mathfunc::min clock}
|
||||
|
||||
test safe-3.1 {calling safe::interpInit is safe} {
|
||||
catch {safe::interpDelete a}
|
||||
interp create a -safe
|
||||
safe::interpInit a
|
||||
catch {interp eval a exec ls} msg
|
||||
safe::interpDelete a
|
||||
set msg
|
||||
} {invalid command name "exec"}
|
||||
test safe-3.2 {calling safe::interpCreate on trusted interp} {
|
||||
catch {safe::interpDelete a}
|
||||
safe::interpCreate a
|
||||
set l [lsort [a aliases]]
|
||||
safe::interpDelete a
|
||||
set l
|
||||
} {::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
|
||||
set x [interp eval a {source [file join $tcl_library init.tcl]}]
|
||||
safe::interpDelete a
|
||||
set x
|
||||
} ""
|
||||
test safe-3.4 {calling safe::interpCreate on trusted interp} {
|
||||
catch {safe::interpDelete a}
|
||||
safe::interpCreate a
|
||||
catch {set x \
|
||||
[interp eval a {source [file join $tcl_library init.tcl]}]} msg
|
||||
safe::interpDelete a
|
||||
list $x $msg
|
||||
} {{} {}}
|
||||
|
||||
test safe-4.1 {safe::interpDelete} {
|
||||
catch {safe::interpDelete a}
|
||||
interp create a
|
||||
safe::interpDelete a
|
||||
} ""
|
||||
test safe-4.2 {safe::interpDelete, indirectly} {
|
||||
catch {safe::interpDelete a}
|
||||
interp create a
|
||||
a alias exit safe::interpDelete a
|
||||
a eval exit
|
||||
} ""
|
||||
|
||||
test safe-4.5 {safe::interpDelete} {
|
||||
catch {safe::interpDelete a}
|
||||
safe::interpCreate a
|
||||
catch {safe::interpCreate a} msg
|
||||
set msg
|
||||
} {interpreter named "a" already exists, cannot create}
|
||||
test safe-4.6 {safe::interpDelete, indirectly} {
|
||||
catch {safe::interpDelete a}
|
||||
safe::interpCreate a
|
||||
a eval exit
|
||||
} ""
|
||||
|
||||
# The following test checks whether the definition of tcl_endOfWord can be
|
||||
# obtained from auto_loading.
|
||||
|
||||
test safe-5.1 {test auto-loading in safe interpreters} {
|
||||
catch {safe::interpDelete a}
|
||||
safe::interpCreate a
|
||||
set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]
|
||||
safe::interpDelete a
|
||||
list $r $msg
|
||||
} {0 -1}
|
||||
|
||||
# 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 [lsort [SafeEval {array names tcl_platform}]]
|
||||
# If running a windows-debug shell, remove the "debug" element from r.
|
||||
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 r
|
||||
} {byteOrder platform pointerSize wordSize}
|
||||
|
||||
# more test should be added to check that hostname, nameofexecutable,
|
||||
# aren't leaking infos, but they still do...
|
||||
|
||||
# high level general test
|
||||
test safe-7.1 {tests that everything works at high level} {
|
||||
set i [safe::interpCreate];
|
||||
# no error shall occur:
|
||||
# (because the default access_path shall include 1st level sub dirs
|
||||
# so package require in a slave works like in the master)
|
||||
set v [interp eval $i {package require http 1}]
|
||||
# no error shall occur:
|
||||
interp eval $i {http_config};
|
||||
safe::interpDelete $i
|
||||
set v
|
||||
} 1.0
|
||||
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
|
||||
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
|
||||
# should not add anything (p0)
|
||||
set token1 [safe::interpAddToAccessPath $i [info library]]
|
||||
# should add as p1
|
||||
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"];
|
||||
# an error shall occur (http is not anymore in the secure 0-level
|
||||
# provided deep path)
|
||||
list $token1 $token2 \
|
||||
[catch {interp eval $i {package require http 1}} msg] $msg \
|
||||
[safe::interpConfigure $i]\
|
||||
[safe::interpDelete $i]
|
||||
} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
|
||||
|
||||
|
||||
# test source control on file name
|
||||
test safe-8.1 {safe source control on file} {
|
||||
set i "a";
|
||||
catch {safe::interpDelete $i}
|
||||
safe::interpCreate $i;
|
||||
list [catch {$i eval {source}} msg] \
|
||||
$msg \
|
||||
[safe::interpDelete $i] ;
|
||||
} {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}
|
||||
safe::interpCreate $i;
|
||||
list [catch {$i eval {source}} msg] \
|
||||
$msg \
|
||||
[safe::interpDelete $i] ;
|
||||
} {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}
|
||||
safe::interpCreate $i;
|
||||
set log {};
|
||||
proc safe-test-log {str} {global log; lappend log $str}
|
||||
set prevlog [safe::setLogCmd];
|
||||
safe::setLogCmd safe-test-log;
|
||||
list [catch {$i eval {source .}} msg] \
|
||||
$msg \
|
||||
$log \
|
||||
[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}
|
||||
safe::interpCreate $i;
|
||||
set log {};
|
||||
proc safe-test-log {str} {global log; lappend log $str}
|
||||
set prevlog [safe::setLogCmd];
|
||||
safe::setLogCmd safe-test-log;
|
||||
list [catch {$i eval {source /abc/def}} msg] \
|
||||
$msg \
|
||||
$log \
|
||||
[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
|
||||
set i "a";
|
||||
catch {safe::interpDelete $i}
|
||||
safe::interpCreate $i;
|
||||
set log {};
|
||||
proc safe-test-log {str} {global log; lappend log $str}
|
||||
set prevlog [safe::setLogCmd];
|
||||
safe::setLogCmd safe-test-log;
|
||||
list [catch {$i eval {source [file join [info lib] blah]}} msg] \
|
||||
$msg \
|
||||
$log \
|
||||
[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}
|
||||
safe::interpCreate $i;
|
||||
set log {};
|
||||
proc safe-test-log {str} {global log; lappend log $str}
|
||||
set prevlog [safe::setLogCmd];
|
||||
safe::setLogCmd safe-test-log;
|
||||
list [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \
|
||||
$msg \
|
||||
$log \
|
||||
[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
|
||||
set i "a";
|
||||
catch {safe::interpDelete $i}
|
||||
safe::interpCreate $i;
|
||||
set log {};
|
||||
proc safe-test-log {str} {global log; lappend log $str}
|
||||
set prevlog [safe::setLogCmd];
|
||||
safe::setLogCmd safe-test-log;
|
||||
list [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\
|
||||
msg] \
|
||||
$msg \
|
||||
$log \
|
||||
[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}
|
||||
safe::interpCreate $i;
|
||||
list [catch {$i eval {source -rsrc Init}} msg] \
|
||||
$msg \
|
||||
[safe::interpDelete $i] ;
|
||||
} {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";
|
||||
catch {safe::interpDelete $i}
|
||||
set res {}
|
||||
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
|
||||
} {{} {arg1 arg2 a}}
|
||||
test safe-9.2 {safe interps' error in deleteHook} {
|
||||
set i "a";
|
||||
catch {safe::interpDelete $i}
|
||||
set res {}
|
||||
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";
|
||||
}
|
||||
set log {};
|
||||
proc safe-test-log {str} {global log; lappend log $str}
|
||||
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
|
||||
set prevlog [safe::setLogCmd];
|
||||
safe::setLogCmd safe-test-log;
|
||||
list [safe::interpDelete $i] $res \
|
||||
$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} -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]
|
||||
} -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]} {
|
||||
testConstraint TcltestPackage 0
|
||||
} else {
|
||||
testConstraint TcltestPackage 1
|
||||
# we use the Tcltest package , which has no Safe_Init
|
||||
}
|
||||
|
||||
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} 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} 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} TcltestPackage {
|
||||
set i [safe::interpCreate -nestedloadok]
|
||||
list \
|
||||
[catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
|
||||
$msg \
|
||||
[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 ..."} {}}
|
||||
test safe-11.2 {testing safe encoding} {
|
||||
set i [safe::interpCreate]
|
||||
list \
|
||||
[catch {interp eval $i encoding system cp775} msg] \
|
||||
$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 {
|
||||
string match [encoding system] [interp eval $i encoding system]
|
||||
} msg]
|
||||
list $result $msg [safe::interpDelete $i]
|
||||
} {0 1 {}}
|
||||
test safe-11.4 {testing safe encoding} {
|
||||
set i [safe::interpCreate]
|
||||
set result [catch {
|
||||
string match [encoding names] [interp eval $i encoding names]
|
||||
} msg]
|
||||
list $result $msg [safe::interpDelete $i]
|
||||
} {0 1 {}}
|
||||
test safe-11.5 {testing safe encoding} {
|
||||
set i [safe::interpCreate]
|
||||
list \
|
||||
[catch {interp eval $i encoding convertfrom cp1258 foobar} msg] \
|
||||
$msg \
|
||||
[safe::interpDelete $i];
|
||||
} {0 foobar {}}
|
||||
test safe-11.6 {testing safe encoding} {
|
||||
set i [safe::interpCreate]
|
||||
list \
|
||||
[catch {interp eval $i encoding convertto cp1258 foobar} msg] \
|
||||
$msg \
|
||||
[safe::interpDelete $i];
|
||||
} {0 foobar {}}
|
||||
test safe-11.7 {testing safe encoding} {
|
||||
set i [safe::interpCreate]
|
||||
list \
|
||||
[catch {interp eval $i encoding convertfrom} msg] \
|
||||
$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 \
|
||||
[catch {interp eval $i encoding convertto} msg] \
|
||||
$msg \
|
||||
[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
|
||||
return
|
||||
Reference in New Issue
Block a user