summaryrefslogtreecommitdiffstats
path: root/tests/safe.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/safe.test')
-rw-r--r--tests/safe.test197
1 files changed, 92 insertions, 105 deletions
diff --git a/tests/safe.test b/tests/safe.test
index a3def0a..fbcb2a1 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
@@ -33,7 +35,6 @@ 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,18 @@ 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-9.1 {safe interps' deleteHook} {
set i "a";
@@ -355,7 +324,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 +346,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 +374,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 +415,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 +429,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 +436,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 +443,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 +450,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 +457,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 +464,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,6 +472,48 @@ 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 {}
set ::auto_path $saveAutoPath
# cleanup
generated by cgit v0.12 at 2024-12-06 00:19:20 (GMT)