safe.test

tcl是工具命令语言

    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} {
    # This tested filename == *.tcl or tclIndex, but that restriction
    # was removed in 8.4a4 - hobbs
    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] ;
} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"] {} {}]


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] ;
} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"] {} {}]


test safe-8.7 {safe source control on file} {
    # This tested length of filename, but that restriction
    # was removed in 8.4a4 - hobbs
    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] ;
} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"] {} {}]

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