summaryrefslogtreecommitdiffstats
path: root/tests/safe.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/safe.test')
-rw-r--r--tests/safe.test527
1 files changed, 0 insertions, 527 deletions
diff --git a/tests/safe.test b/tests/safe.test
deleted file mode 100644
index 5149c59..0000000
--- a/tests/safe.test
+++ /dev/null
@@ -1,527 +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.
-# 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.5 1999/04/16 00:47:33 stanton Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
-}
-
-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
-} {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]\": 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 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} {}}
-
-
-}
-
-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"} {}}
-
-
-# cleanup
-::tcltest::cleanupTests
-return
-
-
-
-
-
-
-
-
-
-
-
-
generated by cgit v0.12 at 2024-07-04 21:25:42 (GMT)