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.22.4.7 2009/12/30 22:20:57 dkf Exp $ 14 15package require Tcl 8.5 16 17if {[lsearch [namespace children] ::tcltest] == -1} { 18 package require tcltest 2 19 namespace import -force ::tcltest::* 20} 21 22foreach i [interp slaves] { 23 interp delete $i 24} 25 26set saveAutoPath $::auto_path 27set ::auto_path [info library] 28 29# Force actual loading of the safe package 30# because we use un exported (and thus un-autoindexed) APIs 31# in this test result arguments: 32catch {safe::interpConfigure} 33 34proc equiv {x} {return $x} 35 36test safe-1.1 {safe::interpConfigure syntax} { 37 list [catch {safe::interpConfigure} msg] $msg; 38} {1 {no value given for parameter "slave" (use -help for full usage) : 39 slave name () name of the slave}} 40test safe-1.2 {safe::interpCreate syntax} { 41 list [catch {safe::interpCreate -help} msg] $msg; 42} {1 {Usage information: 43 Var/FlagName Type Value Help 44 ------------ ---- ----- ---- 45 ( -help gives this help ) 46 ?slave? name () name of the slave (optional) 47 -accessPath list () access path for the slave 48 -noStatics boolflag (false) prevent loading of statically linked pkgs 49 -statics boolean (true) loading of statically linked pkgs 50 -nestedLoadOk boolflag (false) allow nested loading 51 -nested boolean (false) nested loading 52 -deleteHook script () delete hook}} 53test 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}} 57 58 59test safe-2.1 {creating interpreters, should have no aliases} emptyTest { 60 # Disabled this test. It tests nothing sensible. [Bug 999612] 61 # interp aliases 62} "" 63test safe-2.2 {creating interpreters, should have no aliases} { 64 catch {safe::interpDelete a} 65 interp create a 66 set l [a aliases] 67 safe::interpDelete a 68 set l 69} "" 70test safe-2.3 {creating safe interpreters, should have no unexpected aliases} { 71 catch {safe::interpDelete a} 72 interp create a -safe 73 set l [a aliases] 74 interp delete a 75 lsort $l 76} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} 77 78test safe-3.1 {calling safe::interpInit is safe} { 79 catch {safe::interpDelete a} 80 interp create a -safe 81 safe::interpInit a 82 catch {interp eval a exec ls} msg 83 safe::interpDelete a 84 set msg 85} {invalid command name "exec"} 86test safe-3.2 {calling safe::interpCreate on trusted interp} { 87 catch {safe::interpDelete a} 88 safe::interpCreate a 89 set l [lsort [a aliases]] 90 safe::interpDelete a 91 set l 92} {::tcl::info::nameofexecutable clock encoding exit file glob load source} 93test safe-3.3 {calling safe::interpCreate on trusted interp} { 94 catch {safe::interpDelete a} 95 safe::interpCreate a 96 set x [interp eval a {source [file join $tcl_library init.tcl]}] 97 safe::interpDelete a 98 set x 99} "" 100test safe-3.4 {calling safe::interpCreate on trusted interp} { 101 catch {safe::interpDelete a} 102 safe::interpCreate a 103 catch {set x \ 104 [interp eval a {source [file join $tcl_library init.tcl]}]} msg 105 safe::interpDelete a 106 list $x $msg 107} {{} {}} 108 109test safe-4.1 {safe::interpDelete} { 110 catch {safe::interpDelete a} 111 interp create a 112 safe::interpDelete a 113} "" 114test safe-4.2 {safe::interpDelete, indirectly} { 115 catch {safe::interpDelete a} 116 interp create a 117 a alias exit safe::interpDelete a 118 a eval exit 119} "" 120 121test safe-4.5 {safe::interpDelete} { 122 catch {safe::interpDelete a} 123 safe::interpCreate a 124 catch {safe::interpCreate a} msg 125 set msg 126} {interpreter named "a" already exists, cannot create} 127test safe-4.6 {safe::interpDelete, indirectly} { 128 catch {safe::interpDelete a} 129 safe::interpCreate a 130 a eval exit 131} "" 132 133# The following test checks whether the definition of tcl_endOfWord can be 134# obtained from auto_loading. 135 136test safe-5.1 {test auto-loading in safe interpreters} { 137 catch {safe::interpDelete a} 138 safe::interpCreate a 139 set r [catch {interp eval a {tcl_endOfWord "" 0}} msg] 140 safe::interpDelete a 141 list $r $msg 142} {0 -1} 143 144# test safe interps 'information leak' 145proc SafeEval {script} { 146 # Helper procedure that ensures the safe interp is cleaned up even if 147 # there is a failure in the script. 148 set SafeInterp [interp create -safe] 149 catch {$SafeInterp eval $script} msg opts 150 interp delete $SafeInterp 151 return -options $opts $msg 152} 153 154test safe-6.1 {test safe interpreters knowledge of the world} { 155 lsort [SafeEval {info globals}] 156} {tcl_interactive tcl_patchLevel tcl_platform tcl_version} 157test safe-6.2 {test safe interpreters knowledge of the world} { 158 SafeEval {info script} 159} {} 160test safe-6.3 {test safe interpreters knowledge of the world} { 161 set r [lsort [SafeEval {array names tcl_platform}]] 162 # If running a windows-debug shell, remove the "debug" element from r. 163 if {[testConstraint win] && ("debug" in $r)} { 164 set r [lreplace $r 1 1] 165 } 166 set threaded [lsearch $r "threaded"] 167 if {$threaded != -1} { 168 set r [lreplace $r $threaded $threaded] 169 } 170 set r 171} {byteOrder platform pointerSize wordSize} 172 173# more test should be added to check that hostname, nameofexecutable, 174# aren't leaking infos, but they still do... 175 176# high level general test 177test safe-7.1 {tests that everything works at high level} { 178 set i [safe::interpCreate]; 179 # no error shall occur: 180 # (because the default access_path shall include 1st level sub dirs 181 # so package require in a slave works like in the master) 182 set v [interp eval $i {package require http 1}] 183 # no error shall occur: 184 interp eval $i {http_config}; 185 safe::interpDelete $i 186 set v 187} 1.0 188test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { 189 set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]; 190 # should not add anything (p0) 191 set token1 [safe::interpAddToAccessPath $i [info library]] 192 # should add as p1 193 set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]; 194 # an error shall occur (http is not anymore in the secure 0-level 195 # provided deep path) 196 list $token1 $token2 \ 197 [catch {interp eval $i {package require http 1}} msg] $msg \ 198 [safe::interpConfigure $i]\ 199 [safe::interpDelete $i] 200} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library * /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" 201 202 203# test source control on file name 204test safe-8.1 {safe source control on file} { 205 set i "a"; 206 catch {safe::interpDelete $i} 207 safe::interpCreate $i; 208 list [catch {$i eval {source}} msg] \ 209 $msg \ 210 [safe::interpDelete $i] ; 211} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} 212test safe-8.2 {safe source control on file} { 213 set i "a"; 214 catch {safe::interpDelete $i} 215 safe::interpCreate $i; 216 list [catch {$i eval {source}} msg] \ 217 $msg \ 218 [safe::interpDelete $i] ; 219} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} 220test safe-8.3 {safe source control on file} { 221 set i "a"; 222 catch {safe::interpDelete $i} 223 safe::interpCreate $i; 224 set log {}; 225 proc safe-test-log {str} {global log; lappend log $str} 226 set prevlog [safe::setLogCmd]; 227 safe::setLogCmd safe-test-log; 228 list [catch {$i eval {source .}} msg] \ 229 $msg \ 230 $log \ 231 [safe::setLogCmd $prevlog; unset log] \ 232 [safe::interpDelete $i] ; 233} {1 {permission denied} {{ERROR for slave a : ".": is a directory}} {} {}} 234test safe-8.4 {safe source control on file} { 235 set i "a"; 236 catch {safe::interpDelete $i} 237 safe::interpCreate $i; 238 set log {}; 239 proc safe-test-log {str} {global log; lappend log $str} 240 set prevlog [safe::setLogCmd]; 241 safe::setLogCmd safe-test-log; 242 list [catch {$i eval {source /abc/def}} msg] \ 243 $msg \ 244 $log \ 245 [safe::setLogCmd $prevlog; unset log] \ 246 [safe::interpDelete $i] ; 247} {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}} {} {}} 248test safe-8.5 {safe source control on file} { 249 # This tested filename == *.tcl or tclIndex, but that restriction 250 # was removed in 8.4a4 - hobbs 251 set i "a"; 252 catch {safe::interpDelete $i} 253 safe::interpCreate $i; 254 set log {}; 255 proc safe-test-log {str} {global log; lappend log $str} 256 set prevlog [safe::setLogCmd]; 257 safe::setLogCmd safe-test-log; 258 list [catch {$i eval {source [file join [info lib] blah]}} msg] \ 259 $msg \ 260 $log \ 261 [safe::setLogCmd $prevlog; unset log] \ 262 [safe::interpDelete $i] ; 263} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"] {} {}] 264test safe-8.6 {safe source control on file} { 265 set i "a"; 266 catch {safe::interpDelete $i} 267 safe::interpCreate $i; 268 set log {}; 269 proc safe-test-log {str} {global log; lappend log $str} 270 set prevlog [safe::setLogCmd]; 271 safe::setLogCmd safe-test-log; 272 list [catch {$i eval {source [file join [info lib] blah.tcl]}} msg] \ 273 $msg \ 274 $log \ 275 [safe::setLogCmd $prevlog; unset log] \ 276 [safe::interpDelete $i] ; 277} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"] {} {}] 278test safe-8.7 {safe source control on file} { 279 # This tested length of filename, but that restriction 280 # was removed in 8.4a4 - hobbs 281 set i "a"; 282 catch {safe::interpDelete $i} 283 safe::interpCreate $i; 284 set log {}; 285 proc safe-test-log {str} {global log; lappend log $str} 286 set prevlog [safe::setLogCmd]; 287 safe::setLogCmd safe-test-log; 288 list [catch {$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}}\ 289 msg] \ 290 $msg \ 291 $log \ 292 [safe::setLogCmd $prevlog; unset log] \ 293 [safe::interpDelete $i] ; 294} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"] {} {}] 295test safe-8.8 {safe source forbids -rsrc} { 296 set i "a"; 297 catch {safe::interpDelete $i} 298 safe::interpCreate $i; 299 list [catch {$i eval {source -rsrc Init}} msg] \ 300 $msg \ 301 [safe::interpDelete $i] ; 302} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} 303test safe-8.9 {safe source and return} -setup { 304 set returnScript [makeFile {return "ok"} return.tcl] 305 catch {safe::interpDelete $i} 306} -body { 307 safe::interpCreate $i 308 set token [safe::interpAddToAccessPath $i [file dirname $returnScript]] 309 $i eval [list source $token/[file tail $returnScript]] 310} -cleanup { 311 catch {safe::interpDelete $i} 312 removeFile $returnScript 313} -result ok 314 315test safe-9.1 {safe interps' deleteHook} { 316 set i "a"; 317 catch {safe::interpDelete $i} 318 set res {} 319 proc testDelHook {args} { 320 global res; 321 # the interp still exists at that point 322 interp eval a {set delete 1} 323 # mark that we've been here (successfully) 324 set res $args; 325 } 326 safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; 327 list [interp eval $i exit] $res 328} {{} {arg1 arg2 a}} 329test safe-9.2 {safe interps' error in deleteHook} { 330 set i "a"; 331 catch {safe::interpDelete $i} 332 set res {} 333 proc testDelHook {args} { 334 global res; 335 # the interp still exists at that point 336 interp eval a {set delete 1} 337 # mark that we've been here (successfully) 338 set res $args; 339 # create an exception 340 error "being catched"; 341 } 342 set log {}; 343 proc safe-test-log {str} {global log; lappend log $str} 344 safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; 345 set prevlog [safe::setLogCmd]; 346 safe::setLogCmd safe-test-log; 347 list [safe::interpDelete $i] $res \ 348 $log \ 349 [safe::setLogCmd $prevlog; unset log]; 350} {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}} {}} 351test safe-9.3 {dual specification of statics} { 352 list [catch {safe::interpCreate -stat true -nostat} msg] $msg 353} {1 {conflicting values given for -statics and -noStatics}} 354test safe-9.4 {dual specification of statics} { 355 # no error shall occur 356 safe::interpDelete [safe::interpCreate -stat false -nostat] 357} {} 358test safe-9.5 {dual specification of nested} { 359 list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg 360} {1 {conflicting values given for -nested and -nestedLoadOk}} 361 362test safe-9.6 {interpConfigure widget like behaviour} -body { 363 # this test shall work, don't try to "fix it" unless 364 # you *really* know what you are doing (ie you are me :p) -- dl 365 list [set i [safe::interpCreate \ 366 -noStatics \ 367 -nestedLoadOk \ 368 -deleteHook {foo bar}]; 369 safe::interpConfigure $i -accessPath /foo/bar ; 370 safe::interpConfigure $i]\ 371 [safe::interpConfigure $i -aCCess]\ 372 [safe::interpConfigure $i -nested]\ 373 [safe::interpConfigure $i -statics]\ 374 [safe::interpConfigure $i -DEL]\ 375 [safe::interpConfigure $i -accessPath /blah -statics 1; 376 safe::interpConfigure $i]\ 377 [safe::interpConfigure $i -deleteHook toto -nosta -nested 0; 378 safe::interpConfigure $i] 379} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} 380 381# testing that nested and statics do what is advertised 382# (we use a static package : Tcltest) 383 384if {[catch {package require Tcltest} msg]} { 385 testConstraint TcltestPackage 0 386} else { 387 testConstraint TcltestPackage 1 388 # we use the Tcltest package , which has no Safe_Init 389} 390 391test safe-10.1 {testing statics loading} TcltestPackage { 392 set i [safe::interpCreate] 393 list \ 394 [catch {interp eval $i {load {} Tcltest}} msg] \ 395 $msg \ 396 [safe::interpDelete $i]; 397} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} 398test safe-10.2 {testing statics loading / -nostatics} TcltestPackage { 399 set i [safe::interpCreate -nostatics] 400 list \ 401 [catch {interp eval $i {load {} Tcltest}} msg] \ 402 $msg \ 403 [safe::interpDelete $i]; 404} {1 {permission denied (static package)} {}} 405test safe-10.3 {testing nested statics loading / no nested by default} TcltestPackage { 406 set i [safe::interpCreate] 407 list \ 408 [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ 409 $msg \ 410 [safe::interpDelete $i]; 411} {1 {permission denied (nested load)} {}} 412test safe-10.4 {testing nested statics loading / -nestedloadok} TcltestPackage { 413 set i [safe::interpCreate -nestedloadok] 414 list \ 415 [catch {interp eval $i {interp create x; load {} Tcltest x}} msg] \ 416 $msg \ 417 [safe::interpDelete $i]; 418} {1 {can't use package in a safe interpreter: no Tcltest_SafeInit procedure} {}} 419 420test safe-11.1 {testing safe encoding} { 421 set i [safe::interpCreate] 422 list \ 423 [catch {interp eval $i encoding} msg] \ 424 $msg \ 425 [safe::interpDelete $i]; 426} {1 {wrong # args: should be "encoding option ..."} {}} 427test safe-11.2 {testing safe encoding} { 428 set i [safe::interpCreate] 429 list \ 430 [catch {interp eval $i encoding system cp775} msg] \ 431 $msg \ 432 [safe::interpDelete $i]; 433} {1 {wrong # args: should be "encoding system"} {}} 434test safe-11.3 {testing safe encoding} { 435 set i [safe::interpCreate] 436 set result [catch { 437 string match [encoding system] [interp eval $i encoding system] 438 } msg] 439 list $result $msg [safe::interpDelete $i] 440} {0 1 {}} 441test safe-11.4 {testing safe encoding} { 442 set i [safe::interpCreate] 443 set result [catch { 444 string match [encoding names] [interp eval $i encoding names] 445 } msg] 446 list $result $msg [safe::interpDelete $i] 447} {0 1 {}} 448test safe-11.5 {testing safe encoding} { 449 set i [safe::interpCreate] 450 list \ 451 [catch {interp eval $i encoding convertfrom cp1258 foobar} msg] \ 452 $msg \ 453 [safe::interpDelete $i]; 454} {0 foobar {}} 455test safe-11.6 {testing safe encoding} { 456 set i [safe::interpCreate] 457 list \ 458 [catch {interp eval $i encoding convertto cp1258 foobar} msg] \ 459 $msg \ 460 [safe::interpDelete $i]; 461} {0 foobar {}} 462test safe-11.7 {testing safe encoding} { 463 set i [safe::interpCreate] 464 list \ 465 [catch {interp eval $i encoding convertfrom} msg] \ 466 $msg \ 467 [safe::interpDelete $i]; 468} {1 {wrong # args: should be "encoding convertfrom ?encoding? data"} {}} 469test safe-11.8 {testing safe encoding} { 470 set i [safe::interpCreate] 471 list \ 472 [catch {interp eval $i encoding convertto} msg] \ 473 $msg \ 474 [safe::interpDelete $i]; 475} {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}} 476 477test safe-12.1 {glob is restricted [Bug 2906841]} -setup { 478 set i [safe::interpCreate] 479} -body { 480 $i eval glob ../* 481} -returnCodes error -cleanup { 482 safe::interpDelete $i 483} -result "permission denied" 484test safe-12.2 {glob is restricted [Bug 2906841]} -setup { 485 set i [safe::interpCreate] 486} -body { 487 $i eval glob -directory .. * 488} -returnCodes error -cleanup { 489 safe::interpDelete $i 490} -result "permission denied" 491test safe-12.3 {glob is restricted [Bug 2906841]} -setup { 492 set i [safe::interpCreate] 493} -body { 494 $i eval glob -join .. * 495} -returnCodes error -cleanup { 496 safe::interpDelete $i 497} -result "permission denied" 498test safe-12.4 {glob is restricted [Bug 2906841]} -setup { 499 set i [safe::interpCreate] 500} -body { 501 $i eval glob -nocomplain ../* 502} -cleanup { 503 safe::interpDelete $i 504} -result {} 505test safe-12.5 {glob is restricted [Bug 2906841]} -setup { 506 set i [safe::interpCreate] 507} -body { 508 $i eval glob -directory .. -nocomplain * 509} -cleanup { 510 safe::interpDelete $i 511} -result {} 512test safe-12.6 {glob is restricted [Bug 2906841]} -setup { 513 set i [safe::interpCreate] 514} -body { 515 $i eval glob -nocomplain -join .. * 516} -cleanup { 517 safe::interpDelete $i 518} -result {} 519 520set ::auto_path $saveAutoPath 521# cleanup 522::tcltest::cleanupTests 523return 524