safe.test

tcl是工具命令语言

# 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.13 2002/05/10 18:47:11 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

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](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 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];