tcl/tests/safe.test

   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 #
   9 # See the file "license.terms" for information on usage and redistribution
  10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11 #
  12 # RCS: @(#) $Id$
  13
  14 if {[string compare test [info procs test]] == 1} then {source defs}
  15
  16 foreach i [interp slaves] {
  17   interp delete $i
  18 }
  19
  20 # Force actual loading of the safe package
  21 # because we use un exported (and thus un-autoindexed) APIs
  22 # in this test result arguments:
  23 catch {safe::interpConfigure}
  24
  25 proc equiv {x} {return $x}
  26
  27 test safe-1.1 {safe::interpConfigure syntax} {
  28     list [catch {safe::interpConfigure} msg] $msg;
  29 } {1 {no value given for parameter "slave" (use -help for full usage) :
  30     slave name () name of the slave}}
  31
  32 test safe-1.2 {safe::interpCreate syntax} {
  33     list [catch {safe::interpCreate -help} msg] $msg;
  34 } {1 {Usage information:
  35     Var/FlagName  Type     Value   Help
  36     ------------  ----     -----   ----
  37     ( -help                        gives this help )
  38     ?slave?       name     ()      name of the slave (optional)
  39     -accessPath   list     ()      access path for the slave
  40     -noStatics    boolflag (false) prevent loading of statically linked pkgs
  41     -statics      boolean  (true)  loading of statically linked pkgs
  42     -nestedLoadOk boolflag (false) allow nested loading
  43     -nested       boolean  (false) nested loading
  44     -deleteHook   script   ()      delete hook}}
  45
  46 test safe-1.3 {safe::interpInit syntax} {
  47     list [catch {safe::interpInit -noStatics} msg] $msg;
  48 } {1 {bad value "-noStatics" for parameter
  49     slave name () name of the slave}}
  50
  51
  52 test safe-2.1 {creating interpreters, should have no aliases} {
  53     interp aliases
  54 } ""
  55 test safe-2.2 {creating interpreters, should have no aliases} {
  56     catch {safe::interpDelete a}
  57     interp create a
  58     set l [a aliases]
  59     safe::interpDelete a
  60     set l
  61 } ""
  62 test safe-2.3 {creating safe interpreters, should have no aliases} {
  63     catch {safe::interpDelete a}
  64     interp create a -safe
  65     set l [a aliases]
  66     interp delete a
  67     set l
  68 } ""
  69
  70 test safe-3.1 {calling safe::interpInit is safe} {
  71     catch {safe::interpDelete a}
  72     interp create a -safe
  73     safe::interpInit a
  74     catch {interp eval a exec ls} msg
  75     safe::interpDelete a
  76     set msg
  77 } {invalid command name "exec"}
  78 test safe-3.2 {calling safe::interpCreate on trusted interp} {
  79     catch {safe::interpDelete a}
  80     safe::interpCreate a
  81     set l [lsort [a aliases]]
  82     safe::interpDelete a
  83     set l
  84 } {exit file load source}
  85 test safe-3.3 {calling safe::interpCreate on trusted interp} {
  86     catch {safe::interpDelete a}
  87     safe::interpCreate a
  88     set x [interp eval a {source [file join $tcl_library init.tcl]}]
  89     safe::interpDelete a
  90     set x
  91 } ""
  92 test safe-3.4 {calling safe::interpCreate on trusted interp} {
  93     catch {safe::interpDelete a}
  94     safe::interpCreate a
  95     catch {set x \
  96                 [interp eval a {source [file join $tcl_library init.tcl]}]} msg
  97     safe::interpDelete a
  98     list $x $msg
  99 } {{} {}}
 100
 101 test safe-4.1 {safe::interpDelete} {
 102     catch {safe::interpDelete a}
 103     interp create a
 104     safe::interpDelete a
 105 } ""
 106 test safe-4.2 {safe::interpDelete, indirectly} {
 107     catch {safe::interpDelete a}
 108     interp create a
 109     a alias exit safe::interpDelete a
 110     a eval exit
 111 } ""
 112 test safe-4.3 {safe::interpDelete, state array (not a public api)} {
 113     catch {safe::interpDelete a}
 114     namespace eval safe {set [InterpStateName a](foo) 33}
 115     # not an error anymore to call it if interp is already
 116     # deleted, to make trhings smooth if it's called twice...
 117     catch {safe::interpDelete a} m1
 118     catch {namespace eval safe {set [InterpStateName a](foo)}} m2
 119     list $m1 $m2
 120 } "{}\
 121    {can't read \"[safe::InterpStateName a]\": no such variable}"
 122
 123
 124 test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} {
 125     catch {safe::interpDelete a}
 126     safe::interpCreate a
 127     namespace eval safe {set [InterpStateName a](foo) 33}
 128     a eval exit
 129     catch {namespace eval safe {set [InterpStateName a](foo)}} msg
 130 } 1
 131
 132 test safe-4.5 {safe::interpDelete} {
 133     catch {safe::interpDelete a}
 134     safe::interpCreate a
 135     catch {safe::interpCreate a} msg
 136     set msg
 137 } {interpreter named "a" already exists, cannot create}
 138 test safe-4.6 {safe::interpDelete, indirectly} {
 139     catch {safe::interpDelete a}
 140     safe::interpCreate a
 141     a eval exit
 142 } ""
 143
 144 # The following test checks whether the definition of tcl_endOfWord can be
 145 # obtained from auto_loading.
 146
 147 test safe-5.1 {test auto-loading in safe interpreters} {
 148     catch {safe::interpDelete a}
 149     safe::interpCreate a
 150     set r [catch {interp eval a {tcl_endOfWord "" 0}} msg]
 151     safe::interpDelete a
 152     list $r $msg
 153 } {0 -1}
 154
 155 # test safe interps 'information leak'
 156 proc SI {} {
 157     global I
 158     set I [interp create -safe];
 159 }
 160 proc DI {} {
 161     global I;
 162     interp delete $I;
 163 }
 164 test safe-6.1 {test safe interpreters knowledge of the world} {
 165     SI; set r [lsort [$I eval {info globals}]]; DI; set r
 166 } {tcl_interactive tcl_patchLevel tcl_platform tcl_version}
 167 test safe-6.2 {test safe interpreters knowledge of the world} {
 168     SI; set r [$I eval {info script}]; DI; set r
 169 } {}
 170 test safe-6.3 {test safe interpreters knowledge of the world} {pcOnly} {
 171     SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r
 172 } {byteOrder debug platform}
 173 test safe-6.3 {test safe interpreters knowledge of the world} {macOrUnix} {
 174     SI; set r [lsort [$I eval {array names tcl_platform}]]; DI; set r
 175 } {byteOrder platform}
 176
 177 # more test should be added to check that hostname, nameofexecutable,
 178 # aren't leaking infos, but they still do...
 179
 180 # high level general test
 181 test safe-7.1 {tests that everything works at high level} {
 182     set i [safe::interpCreate];
 183     # no error shall occur:
 184     # (because the default access_path shall include 1st level sub dirs
 185     #  so package require in a slave works like in the master)
 186     set v [interp eval $i {package require http 1}]
 187     # no error shall occur:
 188     interp eval $i {http_config};
 189     safe::interpDelete $i
 190     set v
 191 } 1.0
 192
 193 test safe-7.2 {tests specific path and interpFind/AddToAccessPath} {
 194     set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]];
 195     # should not add anything (p0)
 196     set token1 [safe::interpAddToAccessPath $i [info library]]
 197     # should add as p1
 198     set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"];
 199     # an error shall occur (http is not anymore in the secure 0-level
 200     # provided deep path)
 201     list $token1 $token2 \
 202             [catch {interp eval $i {package require http 1}} msg] $msg \
 203             [safe::interpConfigure $i]\
 204             [safe::interpDelete $i]
 205 } "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
 206
 207
 208 # test source control on file name
 209 test safe-8.1 {safe source control on file} {
 210     set i "a";
 211     catch {safe::interpDelete $i}
 212     safe::interpCreate $i;
 213     list  [catch {$i eval {source}} msg] \
 214             $msg \
 215             [safe::interpDelete $i] ;
 216 } {1 {wrong # args: should be "source fileName"} {}}
 217
 218 # test source control on file name
 219 test safe-8.2 {safe source control on file} {
 220     set i "a";
 221     catch {safe::interpDelete $i}
 222     safe::interpCreate $i;
 223     list  [catch {$i eval {source}} msg] \
 224             $msg \
 225             [safe::interpDelete $i] ;
 226 } {1 {wrong # args: should be "source fileName"} {}}
 227
 228 test safe-8.3 {safe source control on file} {
 229     set i "a";
 230     catch {safe::interpDelete $i}
 231     safe::interpCreate $i;
 232     set log {};
 233     proc safe-test-log {str} {global log; lappend log $str}
 234     set prevlog [safe::setLogCmd];
 235     safe::setLogCmd safe-test-log;
 236     list  [catch {$i eval {source .}} msg] \
 237             $msg \
 238             $log \
 239             [safe::setLogCmd $prevlog; unset log] \
 240             [safe::interpDelete $i] ;
 241 } {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}}
 242
 243
 244 test safe-8.4 {safe source control on file} {
 245     set i "a";
 246     catch {safe::interpDelete $i}
 247     safe::interpCreate $i;
 248     set log {};
 249     proc safe-test-log {str} {global log; lappend log $str}
 250     set prevlog [safe::setLogCmd];
 251     safe::setLogCmd safe-test-log;
 252     list  [catch {$i eval {source /abc/def}} msg] \
 253             $msg \
 254             $log \
 255             [safe::setLogCmd $prevlog; unset log] \
 256             [safe::interpDelete $i] ;
 257 } {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}}
 258
 259
 260 test safe-8.5 {safe source control on file} {
 261     set i "a";
 262     catch {safe::interpDelete $i}
 263     safe::interpCreate $i;
 264     set log {};
 265     proc safe-test-log {str} {global log; lappend log $str}
 266     set prevlog [safe::setLogCmd];
 267     safe::setLogCmd safe-test-log;
 268     list  [catch {$i eval {source [file join [info lib] blah]}} msg] \
 269             $msg \
 270             $log \
 271             [safe::setLogCmd $prevlog; unset log] \
 272             [safe::interpDelete $i] ;
 273 } "1 {blah: must be a *.tcl or tclIndex} {{ERROR for slave a : [file join [info library] blah]:blah: must be a *.tcl or tclIndex}} {} {}"
 274
 275
 276 test safe-8.6 {safe source control on file} {
 277     set i "a";
 278     catch {safe::interpDelete $i}
 279     safe::interpCreate $i;
 280     set log {};
 281     proc safe-test-log {str} {global log; lappend log $str}
 282     set prevlog [safe::setLogCmd];
 283     safe::setLogCmd safe-test-log;
 284     list  [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \
 285             $msg \
 286             $log \
 287             [safe::setLogCmd $prevlog; unset log] \
 288             [safe::interpDelete $i] ;
 289 } "1 {no such file or directory} {{ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory}} {} {}"
 290
 291
 292 test safe-8.7 {safe source control on file} {
 293     set i "a";
 294     catch {safe::interpDelete $i}
 295     safe::interpCreate $i;
 296     set log {};
 297     proc safe-test-log {str} {global log; lappend log $str}
 298     set prevlog [safe::setLogCmd];
 299     safe::setLogCmd safe-test-log;
 300     list  [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\
 301                  msg] \
 302             $msg \
 303             $log \
 304             [safe::setLogCmd $prevlog; unset log] \
 305             [safe::interpDelete $i] ;
 306 } "1 {xxxxxxxxxxx.tcl: filename too long} {{ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:xxxxxxxxxxx.tcl: filename too long}} {} {}"
 307
 308 test safe-8.8 {safe source forbids -rsrc} {
 309     set i "a";
 310     catch {safe::interpDelete $i}
 311     safe::interpCreate $i;
 312     list  [catch {$i eval {source -rsrc Init}} msg] \
 313             $msg \
 314             [safe::interpDelete $i] ;
 315 } {1 {wrong # args: should be "source fileName"} {}}
 316
 317
 318 test safe-9.1 {safe interps' deleteHook} {
 319     set i "a";
 320     catch {safe::interpDelete $i}
 321     set res {}
 322     proc testDelHook {args} {
 323         global res;
 324         # the interp still exists at that point
 325         interp eval a {set delete 1}
 326         # mark that we've been here (successfully)
 327         set res $args;
 328     }
 329     safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
 330     list [interp eval $i exit] $res
 331 } {{} {arg1 arg2 a}}
 332
 333 test safe-9.2 {safe interps' error in deleteHook} {
 334     set i "a";
 335     catch {safe::interpDelete $i}
 336     set res {}
 337     proc testDelHook {args} {
 338         global res;
 339         # the interp still exists at that point
 340         interp eval a {set delete 1}
 341         # mark that we've been here (successfully)
 342         set res $args;
 343         # create an exception
 344         error "being catched";
 345     }
 346     set log {};
 347     proc safe-test-log {str} {global log; lappend log $str}
 348     safe::interpCreate $i -deleteHook "testDelHook arg1 arg2";
 349     set prevlog [safe::setLogCmd];
 350     safe::setLogCmd safe-test-log;
 351     list  [safe::interpDelete $i] $res \
 352             $log \
 353             [safe::setLogCmd $prevlog; unset log];
 354 } {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}}
 355
 356
 357 test safe-9.3 {dual specification of statics} {
 358     list [catch {safe::interpCreate -stat true -nostat} msg] $msg
 359 } {1 {conflicting values given for -statics and -noStatics}}
 360
 361 test safe-9.4 {dual specification of statics} {
 362     # no error shall occur
 363     safe::interpDelete [safe::interpCreate -stat false -nostat]
 364 } {}
 365
 366 test safe-9.5 {dual specification of nested} {
 367     list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg
 368 } {1 {conflicting values given for -nested and -nestedLoadOk}}
 369
 370 test safe-9.6 {interpConfigure widget like behaviour} {
 371    # this test shall work, don't try to "fix it" unless
 372    # you *really* know what you are doing (ie you are me :p) -- dl
 373    list [set i [safe::interpCreate \
 374                                    -noStatics \
 375                                    -nestedLoadOk \
 376                                    -deleteHook {foo bar}];
 377          safe::interpConfigure $i -accessPath /foo/bar ;
 378          safe::interpConfigure $i]\
 379         [safe::interpConfigure $i -aCCess]\
 380         [safe::interpConfigure $i -nested]\
 381         [safe::interpConfigure $i -statics]\
 382         [safe::interpConfigure $i -DEL]\
 383         [safe::interpConfigure $i -accessPath /blah -statics 1;
 384          safe::interpConfigure $i]\
 385         [safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
 386          safe::interpConfigure $i]
 387 } {{-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}}
 388
 389
 390 # testing that nested and statics do what is advertised
 391 # (we use a static package : Tcltest)
 392
 393 if {[catch {package require Tcltest} msg]} {
 394     puts "This application hasn't been compiled with Tcltest"
 395     puts "skipping remining safe test that relies on it."
 396 } else {
 397
 398     # we use the Tcltest package , which has no Safe_Init
 399
 400 test safe-10.1 {testing statics loading} {
 401     set i [safe::interpCreate]
 402     list \
 403             [catch {interp eval $i {load {} Tcltest}} msg] \
 404             $msg \
 405             [safe::interpDelete $i];
 406 } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
 407
 408 test safe-10.2 {testing statics loading / -nostatics} {
 409     set i [safe::interpCreate -nostatics]
 410     list \
 411             [catch {interp eval $i {load {} Tcltest}} msg] \
 412             $msg \
 413             [safe::interpDelete $i];
 414 } {1 {permission denied (static package)} {}}
 415
 416
 417
 418 test safe-10.3 {testing nested statics loading / no nested by default} {
 419     set i [safe::interpCreate]
 420     list \
 421             [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
 422             $msg \
 423             [safe::interpDelete $i];
 424 } {1 {permission denied (nested load)} {}}
 425
 426
 427 test safe-10.4 {testing nested statics loading / -nestedloadok} {
 428     set i [safe::interpCreate -nestedloadok]
 429     list \
 430             [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \
 431             $msg \
 432             [safe::interpDelete $i];
 433 } {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}}
 434
 435
 436 }