# 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. # # RCS: @(#) $Id: safe.test,v 1.1.1.2 2009/03/23 15:10:42 duncan Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 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} { 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 } {encoding 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](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} 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 # If running a windows-debug shell, remove the "debug" element from r. if {$tcl_platform(platform) == "windows" && \ [lsearch $r "debug"] != -1} { 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} # 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} { # 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 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} {}} } 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 ...?"} {}} 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"} {}} set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests return