diff options
Diffstat (limited to 'contrib/tcl/tests/safe.test')
| -rw-r--r-- | contrib/tcl/tests/safe.test | 595 |
1 files changed, 337 insertions, 258 deletions
diff --git a/contrib/tcl/tests/safe.test b/contrib/tcl/tests/safe.test index 702bf8d..d68424b 100644 --- a/contrib/tcl/tests/safe.test +++ b/contrib/tcl/tests/safe.test @@ -1,6 +1,6 @@ # safe.test -- # -# This file contains a collection of tests for security policies, safe Tcl, +# 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. # @@ -9,10 +9,7 @@ # 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.13 97/06/24 17:33:22 - -# NOTE: The tests in this file only pass if you invoke them from the -# "tests" directory. +# SCCS: @(#) safe.test 1.31 97/08/14 00:55:56 if {[string compare test [info procs test]] == 1} then {source defs} @@ -20,305 +17,387 @@ 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 {creating interpreters, should have no aliases} { +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 + -nestedLoadOk boolflag (false) allow 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-1.2 {creating interpreters, should have no aliases} { - catch {tcl_safeDeleteInterp a} +test safe-2.2 {creating interpreters, should have no aliases} { + catch {safe::interpDelete a} interp create a set l [a aliases] - interp delete a + safe::interpDelete a set l } "" -test safe-1.3 {creating safe interpreters, should have no aliases} { - catch {tcl_safeDeleteInterp a} +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-2.1 {calling tcl_SafeInit is safe} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a +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 - tcl_safeDeleteInterp a + safe::interpDelete a set msg } {invalid command name "exec"} -test safe-2.2 {calling tcl_safeCreateInterp on trusted interp} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a +test safe-3.2 {calling safe::interpCreate on trusted interp} { + catch {safe::interpDelete a} + safe::interpCreate a set l [lsort [a aliases]] - tcl_safeDeleteInterp a + safe::interpDelete a set l -} {exit file load source tclPkgUnknown} -test safe-2.3 {calling tcl_safeCreateInterp on trusted interp} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a +} {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]}] - tcl_safeDeleteInterp a + safe::interpDelete a set x } "" -test safe-2.4 {calling tcl_safeCreateInterp on trusted interp} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a +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 - tcl_safeDeleteInterp a + safe::interpDelete a list $x $msg } {{} {}} -test safe-3.1 {tcl_safeDeleteInterp} { - catch {tcl_safeDeleteInterp a} +test safe-4.1 {safe::interpDelete} { + catch {safe::interpDelete a} interp create a - tcl_safeDeleteInterp a + safe::interpDelete a } "" -test safe-3.2 {tcl_safeDeleteInterp, indirectly} { - catch {tcl_safeDeleteInterp a} +test safe-4.2 {safe::interpDelete, indirectly} { + catch {safe::interpDelete a} interp create a - a alias exit tcl_safeDeleteInterp a + a alias exit safe::interpDelete a a eval exit } "" -test safe-3.3 {tcl_safeDeleteInterp, state array} { - catch {tcl_safeDeleteInterp a} - set tclSafea(foo) 33 - tcl_safeDeleteInterp a - catch {set tclSafea(foo)} msg - set msg -} {can't read "tclSafea(foo)": no such variable} -test safe-3.4 {tcl_safeDeleteInterp, state array, indirectly} { - catch {tcl_safeDeleteInterp a} - set tclSafea(foo) 33 - tcl_safeCreateInterp a +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 {set tclSafea(foo)} msg - set msg -} {can't read "tclSafea(foo)": no such variable} -test safe-3.5 {tcl_safeDeleteInterp} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - catch {tcl_safeCreateInterp a} msg + 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-3.6 {tcl_safeDeleteInterp, indirectly} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a +test safe-4.6 {safe::interpDelete, indirectly} { + catch {safe::interpDelete a} + safe::interpCreate a a eval exit } "" -test safe-3.7 {tcl_safeDeleteInterp, state array} { - catch {tcl_safeDeleteInterp a} - set tclSafea(foo) 33 - tcl_safeCreateInterp a - tcl_safeDeleteInterp a - catch {set tclSafea(foo)} msg - set msg -} {can't read "tclSafea(foo)": no such variable} -test safe-3.8 {tcl_safeDeleteInterp, state array, indirectly} { - catch {tcl_safeDeleteInterp a} - set tclSafea(foo) 33 - tcl_safeCreateInterp a - a eval exit - catch {set tclSafea(foo)} msg - set msg -} {can't read "tclSafea(foo)": no such variable} -# For the following tests, we need a policyPath; we assume that the -# test directory has a subdirectory policies, and we will use that. +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. -# Save old value of tcl_PolicyPath so we can restore it once we are -# done with this test sequence: +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} -set my_old_auto_path $auto_path -lappend auto_path [pwd] +# 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} -test safe-4.1 {loading a policy from the main directory} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l [a eval {package require globalPolicy}] - tcl_safeDeleteInterp a - set l -} 1.0 -test safe-4.2 {same, loading into safe interpreter} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l [a eval {package require globalPolicy}] - tcl_safeDeleteInterp a - set l -} 1.0 -test safe-4.3 {loading a policy from a subdirectory} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l [a eval {package require policyA}] - tcl_safeDeleteInterp a - set l +# 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-4.4 {loading a policy, unloading, reloading -- clean} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyA}] - tcl_safeDeleteInterp a - tcl_safeCreateInterp a - lappend l [a eval {package require policyA}] - tcl_safeDeleteInterp a - set l -} {1.0 1.0} -test safe-4.5 {loading two policies - prevented} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyA}] - lappend l [catch {a eval {package require policyB}} msg] - lappend l $msg - tcl_safeDeleteInterp a - set l -} {1.0 1 {security policy policyA already loaded}} -test safe-4.6 {two interpreters can have different policies} { - catch {tcl_safeDeleteInterp a} - catch {tcl_safeDeleteInterp b} - tcl_safeCreateInterp a - tcl_safeCreateInterp b - set l "" - lappend l [a eval {package require policyA}] - lappend l [b eval {package require policyB}] - tcl_safeDeleteInterp a - tcl_safeDeleteInterp b - set l -} {1.0 1.0} -test safe-4.7 {safe, loading policy, unloading, reloading: clean} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyA}] - tcl_safeDeleteInterp a - tcl_safeCreateInterp a - lappend l [a eval {package require policyA}] - tcl_safeDeleteInterp a - set l -} {1.0 1.0} -test safe-4.8 {safe, loading two policies - prevented} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyA}] - lappend l [catch {a eval {package require policyB}} msg] - lappend l $msg - tcl_safeDeleteInterp a - set l -} {1.0 1 {security policy policyA already loaded}} -test safe-4.9 {safe, two interpreters have different policies} { - catch {tcl_safeDeleteInterp a} - catch {tcl_safeDeleteInterp b} - tcl_safeCreateInterp a - tcl_safeCreateInterp b - set l "" - lappend l [a eval {package require policyA}] - lappend l [b eval {package require policyB}] - tcl_safeDeleteInterp a - tcl_safeDeleteInterp b - set l -} {1.0 1.0} - -test safe-5.1 {unloading runs policy cleanup code} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyC}] - tcl_safeDeleteInterp a - set l ;# the cleanup side-effects the global variable "l" -} {1.0 bye} - -# For the following tests we need an auto_path that has the policies and -# packages directories in it. - -lappend auto_path [file join [pwd] policies] \ - [file join [pwd] policies packages] - -proc findPackage {i n} { - set l [$i eval {package names}] - if {[lsearch $l $n] > -1} { - return 1 + +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} { + set i [safe::interpCreate -nostat -nested -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 {$tcl_library /dummy/unixlike/test/path} -noStatics -nestedLoadOk -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; } - return 0 -} + safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; + list [interp eval $i exit] $res +} {{} {arg1 arg2 a}} -test safe-6.1 {loading packages still works} { - catch {tcl_safeDeleteInterp a} - interp create a - set l "" - a eval [list set auto_path $auto_path] - lappend l [a eval {package require packageA 1.0}] - lappend l [a eval hoohum] - lappend l [a eval info proc hoohum] - tcl_safeDeleteInterp a - set l -} {1.0 bazooka hoohum} -test safe-6.2 {tcl_safeCreateInterp, loading packages} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require packageA 1.0}] - lappend l [a eval hoohum] - lappend l [a eval info proc hoohum] - tcl_safeDeleteInterp a - set l -} {1.0 bazooka hoohum} -test safe-6.3 {policies vs packages} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyA}] - lappend l [a eval {package require packageA}] - lappend l [findPackage a policyA] - lappend l [findPackage a packageA] - lappend l [findPackage a hohum] - tcl_safeDeleteInterp a - set l -} {1.0 1.0 1 1 0} -test safe-6.4 {policies vs packages} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyA}] - lappend l [a eval {package require packageA}] - lappend l [findPackage a Tcl] - lappend l [findPackage a policyA] - lappend l [findPackage a hohum] - tcl_safeDeleteInterp a - set l -} {1.0 1.0 1 1 0} -test safe-6.5 {policies vs packages vs policies} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set l "" - lappend l [a eval {package require policyA}] - lappend l [a eval {package require packageA}] - catch {a eval {package require policyB}} msg - lappend l $msg - lappend l [findPackage a Tcl] - lappend l [findPackage a policyA] - lappend l [findPackage a policyB] - tcl_safeDeleteInterp a - set l -} {1.0 1.0 {security policy policyA already loaded} 1 1 0} +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}} {}} -# The following test checks whether the definition of tcl_endOfWord can be -# obtained from auto_loading. -test safe-7.1 {test auto-loading in safe interpreters} { - catch {tcl_safeDeleteInterp a} - tcl_safeCreateInterp a - set r [catch {interp eval a {tcl_endOfWord "" 0}} msg] - tcl_safeDeleteInterp a - list $r $msg -} {0 -1} -# Restore settings to what they were before this file was sourced: +# features which still need test cases: +# -nostatics and -nestedloadok which +# are not easily tested from tclsh, can be +# tested in wish though (safetk.test) +# (we'd need a static package) +# we have 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 { -set auto_path $my_old_auto_path -unset my_old_auto_path + # we use the Tcltest package , which has no Safe_Init -# set auto_path $old_auto_path -# unset old_auto_path +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 -nested] + 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} {}} + + +} |
