434 lines
14 KiB
Plaintext
434 lines
14 KiB
Plaintext
# 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} {}}
|
|
|
|
|
|
}
|