Subversion Repositories or1k

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

#

# RCS: @(#) $Id: safe.test,v 1.1.1.1 2002-01-16 10:25:36 markom Exp $

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} {pcOnly} {

    SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r

} {byteOrder debug platform}

test safe-6.3 {test safe interpreters knowledge of the world} {macOrUnix} {

    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} {}}

}