path: root/contrib/tcl/tests/safe.test

# safe.test --
#
# This file contains a collection of tests for security policies, safe Tcl,
# 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.13 97/06/24 17:33:22

# NOTE: The tests in this file only pass if you invoke them from the
#	"tests" directory.

if {[string compare test [info procs test]] == 1} then {source defs}

foreach i [interp slaves] {
  interp delete $i
}

proc equiv {x} {return $x}

test safe-1.1 {creating interpreters, should have no aliases} {
    interp aliases
} ""
test safe-1.2 {creating interpreters, should have no aliases} {
    catch {tcl_safeDeleteInterp a}
    interp create a
    set l [a aliases]
    interp delete a
    set l
} ""
test safe-1.3 {creating safe interpreters, should have no aliases} {
    catch {tcl_safeDeleteInterp 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
    catch {interp eval a exec ls} msg
    tcl_safeDeleteInterp a
    set msg
} {invalid command name "exec"}
test safe-2.2 {calling tcl_safeCreateInterp on trusted interp} {
    catch {tcl_safeDeleteInterp a}
    tcl_safeCreateInterp a
    set l [lsort [a aliases]]
    tcl_safeDeleteInterp 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
    set x [interp eval a {source [file join $tcl_library init.tcl]}]
    tcl_safeDeleteInterp a
    set x
} ""
test safe-2.4 {calling tcl_safeCreateInterp on trusted interp} {
    catch {tcl_safeDeleteInterp a}
    tcl_safeCreateInterp a
    catch {set x \
		[interp eval a {source [file join $tcl_library init.tcl]}]} msg
    tcl_safeDeleteInterp a
    list $x $msg
} {{} {}}

test safe-3.1 {tcl_safeDeleteInterp} {
    catch {tcl_safeDeleteInterp a}
    interp create a
    tcl_safeDeleteInterp a
} ""
test safe-3.2 {tcl_safeDeleteInterp, indirectly} {
    catch {tcl_safeDeleteInterp a}
    interp create a
    a alias exit tcl_safeDeleteInterp 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
    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
    set msg
} {interpreter named "a" already exists, cannot create}
test safe-3.6 {tcl_safeDeleteInterp, indirectly} {
    catch {tcl_safeDeleteInterp a}
    tcl_safeCreateInterp 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.

# Save old value of tcl_PolicyPath so we can restore it once we are
# done with this test sequence:

set my_old_auto_path $auto_path
lappend auto_path [pwd]

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
} 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
    }
    return 0
}

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}

# 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:

set auto_path $my_old_auto_path
unset my_old_auto_path

# set auto_path $old_auto_path
# unset old_auto_path