Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/safe.test@260cb5ec6c19

     1 # safe.test --

2 #

     3 # This file contains a collection of tests for safe Tcl, packages loading,

     4 # and using safe interpreters. Sourcing this file into tcl runs the tests

     5 # and generates output for errors.  No output means no errors were found.

6 #

     7 # Copyright (c) 1995-1996 Sun Microsystems, Inc.

     8 # Copyright (c) 1998-1999 by Scriptics Corporation.

9 #

    10 # See the file "license.terms" for information on usage and redistribution

    11 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

    12 #

    13 # RCS: @(#) $Id: safe.test,v 1.13.2.3 2006/11/28 22:20:03 andreas_kupries Exp $

    15 if {[lsearch [namespace children] ::tcltest] == -1} {

    16     package require tcltest

    17     namespace import -force ::tcltest::*

    18 }

    20 foreach i [interp slaves] {

    21   interp delete $i

    22 }

    24 set saveAutoPath $::auto_path

    25 set ::auto_path [info library]

    27 # Force actual loading of the safe package

    28 # because we use un exported (and thus un-autoindexed) APIs

    29 # in this test result arguments:

    30 catch {safe::interpConfigure}

    32 proc equiv {x} {return $x}

    34 test safe-1.1 {safe::interpConfigure syntax} {

    35     list [catch {safe::interpConfigure} msg] $msg;

    36 } {1 {no value given for parameter "slave" (use -help for full usage) :

    37     slave name () name of the slave}}

    39 test safe-1.2 {safe::interpCreate syntax} {

    40     list [catch {safe::interpCreate -help} msg] $msg;

    41 } {1 {Usage information:

    42     Var/FlagName  Type     Value   Help

    43     ------------  ----     -----   ----

    44     ( -help                        gives this help )

    45     ?slave?       name     ()      name of the slave (optional)

    46     -accessPath   list     ()      access path for the slave

    47     -noStatics    boolflag (false) prevent loading of statically linked pkgs

    48     -statics      boolean  (true)  loading of statically linked pkgs

    49     -nestedLoadOk boolflag (false) allow nested loading

    50     -nested       boolean  (false) nested loading

    51     -deleteHook   script   ()      delete hook}}

    53 test safe-1.3 {safe::interpInit syntax} {

    54     list [catch {safe::interpInit -noStatics} msg] $msg;

    55 } {1 {bad value "-noStatics" for parameter

    56     slave name () name of the slave}}

    59 test safe-2.1 {creating interpreters, should have no aliases} {

    60     interp aliases

    61 } ""

    62 test safe-2.2 {creating interpreters, should have no aliases} {

    63     catch {safe::interpDelete a}

    64     interp create a

    65     set l [a aliases]

    66     safe::interpDelete a

    67     set l

    68 } ""

    69 test safe-2.3 {creating safe interpreters, should have no aliases} {

    70     catch {safe::interpDelete a}

    71     interp create a -safe

    72     set l [a aliases]

    73     interp delete a

    74     set l

    75 } ""

    77 test safe-3.1 {calling safe::interpInit is safe} {

    78     catch {safe::interpDelete a}

    79     interp create a -safe

    80     safe::interpInit a

    81     catch {interp eval a exec ls} msg

    82     safe::interpDelete a

    83     set msg

    84 } {invalid command name "exec"}

    85 test safe-3.2 {calling safe::interpCreate on trusted interp} {

    86     catch {safe::interpDelete a}

    87     safe::interpCreate a

    88     set l [lsort [a aliases]]

    89     safe::interpDelete a

    90     set l

    91 } {encoding exit file load source}

    92 test safe-3.3 {calling safe::interpCreate on trusted interp} {

    93     catch {safe::interpDelete a}

    94     safe::interpCreate a

    95     set x [interp eval a {source [file join $tcl_library init.tcl]}]

    96     safe::interpDelete a

    97     set x

    98 } ""

    99 test safe-3.4 {calling safe::interpCreate on trusted interp} {

   100     catch {safe::interpDelete a}

   101     safe::interpCreate a

   102     catch {set x \

   103 		[interp eval a {source [file join $tcl_library init.tcl]}]} msg

   104     safe::interpDelete a

   105     list $x $msg

   106 } {{} {}}

   108 test safe-4.1 {safe::interpDelete} {

   109     catch {safe::interpDelete a}

   110     interp create a

   111     safe::interpDelete a

   112 } ""

   113 test safe-4.2 {safe::interpDelete, indirectly} {

   114     catch {safe::interpDelete a}

   115     interp create a

   116     a alias exit safe::interpDelete a

   117     a eval exit

   118 } ""

   119 test safe-4.3 {safe::interpDelete, state array (not a public api)} {

   120     catch {safe::interpDelete a}

   121     namespace eval safe {set [InterpStateName a](foo) 33}

   122     # not an error anymore to call it if interp is already

   123     # deleted, to make trhings smooth if it's called twice...

   124     catch {safe::interpDelete a} m1

   125     catch {namespace eval safe {set [InterpStateName a](foo)}} m2

   126     list $m1 $m2

   127 } "{}\

   128    {can't read \"[safe::InterpStateName a](foo)\": no such variable}"

   131 test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} {

   132     catch {safe::interpDelete a}

   133     safe::interpCreate a

   134     namespace eval safe {set [InterpStateName a](foo) 33}

   135     a eval exit

   136     catch {namespace eval safe {set [InterpStateName a](foo)}} msg

   137 } 1

   139 test safe-4.5 {safe::interpDelete} {

   140     catch {safe::interpDelete a}

   141     safe::interpCreate a

   142     catch {safe::interpCreate a} msg

   143     set msg

   144 } {interpreter named "a" already exists, cannot create}

   145 test safe-4.6 {safe::interpDelete, indirectly} {

   146     catch {safe::interpDelete a}

   147     safe::interpCreate a

   148     a eval exit

   149 } ""

   151 # The following test checks whether the definition of tcl_endOfWord can be

   152 # obtained from auto_loading.

   154 test safe-5.1 {test auto-loading in safe interpreters} {

   155     catch {safe::interpDelete a}

   156     safe::interpCreate a

   157     set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]

   158     safe::interpDelete a

   159     list $r $msg

   160 } {0 -1}

   162 # test safe interps 'information leak'

   163 proc SI {} {

   164     global I

   165     set I [interp create -safe];

   166 }

   167 proc DI {} {

   168     global I;

   169     interp delete $I;

   170 }

   171 test safe-6.1 {test safe interpreters knowledge of the world} {

   172     SI; set r [lsort [$I eval {info globals}]]; DI; set r

   173 } {tcl_interactive tcl_patchLevel tcl_platform tcl_version}

   174 test safe-6.2 {test safe interpreters knowledge of the world} {

   175     SI; set r [$I eval {info script}]; DI; set r

   176 } {}

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

   178     SI

   179     set r [lsort [$I eval {array names tcl_platform}]]

   180     DI

   181     # If running a windows-debug shell, remove the "debug" element from r.

   182     if {$tcl_platform(platform) == "windows" && \

   183 	    [lsearch $r "debug"] != -1} {

   184 	set r [lreplace $r 1 1]

   185     }

   186     set threaded [lsearch $r "threaded"]

   187     if {$threaded != -1} {

   188 	set r [lreplace $r $threaded $threaded]

   189     }

   190     set tip [lsearch $r "tip,268"]

   191     if {$tip != -1} {

   192 	set r [lreplace $r $tip $tip]

   193     }

   194     set tip [lsearch $r "tip,280"]

   195     if {$tip != -1} {

   196 	set r [lreplace $r $tip $tip]

   197     }

   198     set r

   199 } {byteOrder platform wordSize}

   201 # more test should be added to check that hostname, nameofexecutable,

   202 # aren't leaking infos, but they still do...

   204 # high level general test

   205 test safe-7.1 {tests that everything works at high level} {

   206     set i [safe::interpCreate];

   207     # no error shall occur:

   208     # (because the default access_path shall include 1st level sub dirs

   209     #  so package require in a slave works like in the master)

   210     set v [interp eval $i {package require http 1}]

   211     # no error shall occur:

   212     interp eval $i {http_config};

   213     safe::interpDelete $i

   214     set v

   215 } 1.0

   217 test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {

   218     set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];

   219     # should not add anything (p0)

   220     set token1 [safe::interpAddToAccessPath $i [info library]]

   221     # should add as p1

   222     set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"];

   223     # an error shall occur (http is not anymore in the secure 0-level

   224     # provided deep path)

   225     list $token1 $token2 \

   226 	    [catch {interp eval $i {package require http 1}} msg] $msg \

   227 	    [safe::interpConfigure $i]\

   228 	    [safe::interpDelete $i]

   229 } "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"

   232 # test source control on file name

   233 test safe-8.1 {safe source control on file} {

   234     set i "a";

   235     catch {safe::interpDelete $i}

   236     safe::interpCreate $i;

   237     list  [catch {$i eval {source}} msg] \

   238 	    $msg \

   239 	    [safe::interpDelete $i] ;

   240 } {1 {wrong # args: should be "source fileName"} {}}

   242 # test source control on file name

   243 test safe-8.2 {safe source control on file} {

   244     set i "a";

   245     catch {safe::interpDelete $i}

   246     safe::interpCreate $i;

   247     list  [catch {$i eval {source}} msg] \

   248 	    $msg \

   249 	    [safe::interpDelete $i] ;

   250 } {1 {wrong # args: should be "source fileName"} {}}

   252 test safe-8.3 {safe source control on file} {

   253     set i "a";

   254     catch {safe::interpDelete $i}

   255     safe::interpCreate $i;

   256     set log {};

   257     proc safe-test-log {str} {global log; lappend log $str}

   258     set prevlog [safe::setLogCmd];

   259     safe::setLogCmd safe-test-log;

   260     list  [catch {$i eval {source .}} msg] \

   261 	    $msg \

   262 	    $log \

   263 	    [safe::setLogCmd $prevlog; unset log] \

   264 	    [safe::interpDelete $i] ;

   265 } {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}}

   268 test safe-8.4 {safe source control on file} {

   269     set i "a";

   270     catch {safe::interpDelete $i}

   271     safe::interpCreate $i;

   272     set log {};

   273     proc safe-test-log {str} {global log; lappend log $str}

   274     set prevlog [safe::setLogCmd];

   275     safe::setLogCmd safe-test-log;

   276     list  [catch {$i eval {source /abc/def}} msg] \

   277 	    $msg \

   278 	    $log \

   279 	    [safe::setLogCmd $prevlog; unset log] \

   280 	    [safe::interpDelete $i] ;

   281 } {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}}

   284 test safe-8.5 {safe source control on file} {

   285     # This tested filename == *.tcl or tclIndex, but that restriction

   286     # was removed in 8.4a4 - hobbs

   287     set i "a";

   288     catch {safe::interpDelete $i}

   289     safe::interpCreate $i;

   290     set log {};

   291     proc safe-test-log {str} {global log; lappend log $str}

   292     set prevlog [safe::setLogCmd];

   293     safe::setLogCmd safe-test-log;

   294     list  [catch {$i eval {source [file join [info lib] blah]}} msg] \

   295 	    $msg \

   296 	    $log \

   297 	    [safe::setLogCmd $prevlog; unset log] \

   298 	    [safe::interpDelete $i] ;

   299 } [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"] {} {}]

   302 test safe-8.6 {safe source control on file} {

   303     set i "a";

   304     catch {safe::interpDelete $i}

   305     safe::interpCreate $i;

   306     set log {};

   307     proc safe-test-log {str} {global log; lappend log $str}

   308     set prevlog [safe::setLogCmd];

   309     safe::setLogCmd safe-test-log;

   310     list  [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \

   311 	    $msg \

   312 	    $log \

   313 	    [safe::setLogCmd $prevlog; unset log] \

   314 	    [safe::interpDelete $i] ;

   315 } [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"] {} {}]

   318 test safe-8.7 {safe source control on file} {

   319     # This tested length of filename, but that restriction

   320     # was removed in 8.4a4 - hobbs

   321     set i "a";

   322     catch {safe::interpDelete $i}

   323     safe::interpCreate $i;

   324     set log {};

   325     proc safe-test-log {str} {global log; lappend log $str}

   326     set prevlog [safe::setLogCmd];

   327     safe::setLogCmd safe-test-log;

   328     list  [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\

   329 		 msg] \

   330 	    $msg \

   331 	    $log \

   332 	    [safe::setLogCmd $prevlog; unset log] \

   333 	    [safe::interpDelete $i] ;

   334 } [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"] {} {}]

   336 test safe-8.8 {safe source forbids -rsrc} {

   337     set i "a";

   338     catch {safe::interpDelete $i}

   339     safe::interpCreate $i;

   340     list  [catch {$i eval {source -rsrc Init}} msg] \

   341 	    $msg \

   342 	    [safe::interpDelete $i] ;

   343 } {1 {wrong # args: should be "source fileName"} {}}

   346 test safe-9.1 {safe interps' deleteHook} {

   347     set i "a";

   348     catch {safe::interpDelete $i}

   349     set res {}

   350     proc testDelHook {args} {

   351 	global res;

   352 	# the interp still exists at that point

   353 	interp eval a {set delete 1}

   354 	# mark that we've been here (successfully)

   355 	set res $args;

   356     }

   357     safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";

   358     list [interp eval $i exit] $res

   359 } {{} {arg1 arg2 a}}

   361 test safe-9.2 {safe interps' error in deleteHook} {

   362     set i "a";

   363     catch {safe::interpDelete $i}

   364     set res {}

   365     proc testDelHook {args} {

   366 	global res;

   367 	# the interp still exists at that point

   368 	interp eval a {set delete 1}

   369 	# mark that we've been here (successfully)

   370 	set res $args;

   371 	# create an exception

   372 	error "being catched";

   373     }

   374     set log {};

   375     proc safe-test-log {str} {global log; lappend log $str}

   376     safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";

   377     set prevlog [safe::setLogCmd];

   378     safe::setLogCmd safe-test-log;

   379     list  [safe::interpDelete $i] $res \

   380 	    $log \

   381 	    [safe::setLogCmd $prevlog; unset log];

   382 } {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}

   385 test safe-9.3 {dual specification of statics} {

   386     list [catch {safe::interpCreate -stat true -nostat} msg] $msg

   387 } {1 {conflicting values given for -statics and -noStatics}}

   389 test safe-9.4 {dual specification of statics} {

   390     # no error shall occur

   391     safe::interpDelete [safe::interpCreate -stat false -nostat]

   392 } {}

   394 test safe-9.5 {dual specification of nested} {

   395     list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg

   396 } {1 {conflicting values given for -nested and -nestedLoadOk}}

   398 test safe-9.6 {interpConfigure widget like behaviour} {

   399    # this test shall work, don't try to "fix it" unless

   400    # you *really* know what you are doing (ie you are me :p) -- dl

   401    list [set i [safe::interpCreate \

   402 	                           -noStatics \

   403                                    -nestedLoadOk \

   404 	                           -deleteHook {foo bar}];

   405          safe::interpConfigure $i -accessPath /foo/bar ;

   406          safe::interpConfigure $i]\

   407 	[safe::interpConfigure $i -aCCess]\

   408 	[safe::interpConfigure $i -nested]\

   409 	[safe::interpConfigure $i -statics]\

   410 	[safe::interpConfigure $i -DEL]\

   411 	[safe::interpConfigure $i -accessPath /blah -statics 1;

   412 	 safe::interpConfigure $i]\

   413 	[safe::interpConfigure $i -deleteHook toto -nosta -nested 0;

   414 	 safe::interpConfigure $i]

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

   418 # testing that nested and statics do what is advertised

   419 # (we use a static package : Tcltest)

   421 if {[catch {package require Tcltest} msg]} {

   422     puts "This application hasn't been compiled with Tcltest"

   423     puts "skipping remining safe test that relies on it."

   424 } else {

   426     # we use the Tcltest package , which has no Safe_Init

   428 test safe-10.1 {testing statics loading} {

   429     set i [safe::interpCreate]

   430     list \

   431 	    [catch {interp eval $i {load {} Tcltest}} msg] \

   432 	    $msg \

   433             [safe::interpDelete $i];

   434 } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}

   436 test safe-10.2 {testing statics loading / -nostatics} {

   437     set i [safe::interpCreate -nostatics]

   438     list \

   439 	    [catch {interp eval $i {load {} Tcltest}} msg] \

   440 	    $msg \

   441             [safe::interpDelete $i];

   442 } {1 {permission denied (static package)} {}}

   446 test safe-10.3 {testing nested statics loading / no nested by default} {

   447     set i [safe::interpCreate]

   448     list \

   449 	    [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \

   450 	    $msg \

   451             [safe::interpDelete $i];

   452 } {1 {permission denied (nested load)} {}}

   455 test safe-10.4 {testing nested statics loading / -nestedloadok} {

   456     set i [safe::interpCreate -nestedloadok]

   457     list \

   458 	    [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \

   459 	    $msg \

   460             [safe::interpDelete $i];

   461 } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}

   464 }

   466 test safe-11.1 {testing safe encoding} {

   467     set i [safe::interpCreate]

   468     list \

   469 	    [catch {interp eval $i encoding} msg] \

   470 	    $msg \

   471 	    [safe::interpDelete $i];

   472 } {1 {wrong # args: should be "encoding option ?arg ...?"} {}}

   474 test safe-11.2 {testing safe encoding} {

   475     set i [safe::interpCreate]

   476     list \

   477 	    [catch {interp eval $i encoding system cp775} msg] \

   478 	    $msg \

   479 	    [safe::interpDelete $i];

   480 } {1 {wrong # args: should be "encoding system"} {}}

   482 test safe-11.3 {testing safe encoding} {

   483     set i [safe::interpCreate]

   484     set result [catch {

   485 	string match [encoding system] [interp eval $i encoding system]

   486     } msg]

   487     list $result $msg [safe::interpDelete $i]

   488 } {0 1 {}}

   490 test safe-11.4 {testing safe encoding} {

   491     set i [safe::interpCreate]

   492     set result [catch {

   493 	string match [encoding names] [interp eval $i encoding names]

   494     } msg]

   495     list $result $msg  [safe::interpDelete $i]

   496 } {0 1 {}}

   498 test safe-11.5 {testing safe encoding} {

   499     set i [safe::interpCreate]

   500     list \

   501 	    [catch {interp eval $i encoding convertfrom cp1258 foobar} msg] \

   502 	    $msg \

   503 	    [safe::interpDelete $i];

   504 } {0 foobar {}}

   507 test safe-11.6 {testing safe encoding} {

   508     set i [safe::interpCreate]

   509     list \

   510 	    [catch {interp eval $i encoding convertto cp1258 foobar} msg] \

   511 	    $msg \

   512 	    [safe::interpDelete $i];

   513 } {0 foobar {}}

   515 test safe-11.7 {testing safe encoding} {

   516     set i [safe::interpCreate]

   517     list \

   518 	    [catch {interp eval $i encoding convertfrom} msg] \

   519 	    $msg \

   520 	    [safe::interpDelete $i];

   521 } {1 {wrong # args: should be "encoding convertfrom ?encoding? data"} {}}

   524 test safe-11.8 {testing safe encoding} {

   525     set i [safe::interpCreate]

   526     list \

   527 	    [catch {interp eval $i encoding convertto} msg] \

   528 	    $msg \

   529 	    [safe::interpDelete $i];

   530 } {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}}

   533 set ::auto_path $saveAutoPath

   534 # cleanup

   535 ::tcltest::cleanupTests

   536 return

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--