diff options
Diffstat (limited to 'contrib/tcl/tests/safe.test')
| -rw-r--r-- | contrib/tcl/tests/safe.test | 433 |
1 files changed, 0 insertions, 433 deletions
diff --git a/contrib/tcl/tests/safe.test b/contrib/tcl/tests/safe.test deleted file mode 100644 index c23f06aa18c8..000000000000 --- a/contrib/tcl/tests/safe.test +++ /dev/null @@ -1,433 +0,0 @@ -# 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. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# SCCS: @(#) safe.test 1.34 97/11/19 14:59:13 - -if {[string compare test [info procs test]] == 1} then {source defs} - -foreach i [interp slaves] { - interp delete $i -} - -# 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} { - 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 aliases} { - catch {safe::interpDelete a} - interp create a -safe - set l [a aliases] - interp delete a - set l -} "" - -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 -} {exit file 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.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]\": 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} - 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 SI {} { - global I - set I [interp create -safe]; -} -proc DI {} { - global I; - interp delete $I; -} -test safe-6.1 {test safe interpreters knowledge of the world} { - SI; set r [lsort [$I eval {info globals}]]; DI; set r -} {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 -} {} -test safe-6.3 {test safe interpreters knowledge of the world} { - SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r -} {byteOrder platform} - -# 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} { - 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] -} "{\$p(:0:)} {\$p(:1:)} 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 fileName"} {}} - -# test source control on file name -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 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} { - 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] ; -} "1 {blah: must be a *.tcl or tclIndex} {{ERROR for slave a : [file join [info library] blah]:blah: must be a *.tcl or tclIndex}} {} {}" - - -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] ; -} "1 {no such file or directory} {{ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory}} {} {}" - - -test safe-8.7 {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] xxxxxxxxxxx.tcl]}}\ - msg] \ - $msg \ - $log \ - [safe::setLogCmd $prevlog; unset log] \ - [safe::interpDelete $i] ; -} "1 {xxxxxxxxxxx.tcl: filename too long} {{ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:xxxxxxxxxxx.tcl: filename too long}} {} {}" - -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 fileName"} {}} - - -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} { - # 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] -} {{-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}} - - -# 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." -} else { - - # we use the Tcltest package , which has no Safe_Init - -test safe-10.1 {testing statics loading} { - 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} { - 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} { - 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} { - 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} {}} - - -} |