From 2aa99d284d6f4194676a3e2f5aac6ad2197a7714 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 3 Dec 2009 15:49:22 +0000 Subject: Fix [Bug 2906841] and a few other smaller issues. --- ChangeLog | 22 ++- library/safe.tcl | 54 +++--- tests/safe.test | 563 +++++++++++++++++++++++++++++-------------------------- 3 files changed, 341 insertions(+), 298 deletions(-) diff --git a/ChangeLog b/ChangeLog index 534d4d3..24089ba 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,15 +1,23 @@ +2009-12-03 Donal K. Fellows + + * library/safe.tcl (::safe::AliasEncoding): Make the safe encoding + command behave more closely like the unsafe one (for safe ops). + (::safe::AliasGlob): [Bug 2906841]: Clamp down on evil use of [glob] + in safe interpreters. + * tests/safe.test: Rewrite to use tcltest2 better. + 2009-12-02 Jan Nijtmans - * tools/genStubs.tcl Add support for win32 CALLBACK functions - and remove obsolete "emitStubs" and "genStubs" functions. - * win/Makefile.in Use tcltest86.dll for all tests, and add - .PHONY rules to preemptively stop trouble that plagued Tk - from hitting Tcl too. + * tools/genStubs.tcl: Add support for win32 CALLBACK functions and + remove obsolete "emitStubs" and "genStubs" functions. + * win/Makefile.in: Use tcltest86.dll for all tests, and add + .PHONY rules to preemptively stop trouble that plagued Tk from hitting + Tcl too. 2009-11-30 Jan Nijtmans - * generic/tcl.h Don't use EXPORT for Tcl_InitStubs - * win/Makefile.in Better dependancies in case of static build. + * generic/tcl.h: Don't use EXPORT for Tcl_InitStubs + * win/Makefile.in: Better dependancies in case of static build. 2009-11-30 Donal K. Fellows diff --git a/library/safe.tcl b/library/safe.tcl index 662a727..8bc26f9 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.tcl,v 1.33 2009/11/19 11:59:54 dkf Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.34 2009/12/03 15:49:22 dkf Exp $ # # The implementation is based on namespaces. These naming conventions are @@ -651,7 +651,6 @@ proc ::safe::CheckFileName {slave file} { } # AliasGlob is the target of the "glob" alias in safe interpreters. - proc ::safe::AliasGlob {slave args} { Log $slave "GLOB ! $args" NOTICE set cmd {} @@ -663,30 +662,22 @@ proc ::safe::AliasGlob {slave args} { while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { -nocomplain - - -join { + -join { lappend cmd $opt incr at } - -directory { - lappend cmd $opt - incr at - set virtualdir [lindex $args $at] - - # get the real path from the virtual one. + -directory { + set virtualdir [lindex $args [incr at]] + # Get the real path from the virtual one and check that the + # path is in the access path of that slave. try { set dir [TranslatePath $slave $virtualdir] - } on error msg { - Log $slave $msg - return -code error "permission denied" - } - # check that the path is in the access path of that slave - try { DirInAccessPath $slave $dir } on error msg { Log $slave $msg return -code error "permission denied" } - lappend cmd $dir + lappend cmd -directory $dir incr at } pkgIndex.tcl { @@ -701,6 +692,14 @@ proc ::safe::AliasGlob {slave args} { return -code error "Safe base rejecting glob option '$opt'" } default { + if {[regexp {(.*)[\\/]} $opt -> thedir]} { + try { + DirInAccessPath $slave [TranslatePath $slave $thedir] + } on error msg { + Log $slave $msg + return -code error "permission denied" + } + } lappend cmd $opt incr at } @@ -928,18 +927,14 @@ proc ::safe::AliasSubset {slave alias target args} { # AliasEncoding is the target of the "encoding" alias in safe interpreters. -proc ::safe::AliasEncoding {slave args} { - set argc [llength $args] - - set okpat "^(name.*|convert.*)\$" - set subcommand [lindex $args 0] - - if {[regexp $okpat $subcommand]} { - return [::interp invokehidden $slave encoding {*}$args] +proc ::safe::AliasEncoding {slave option args} { + # Careful; do not want empty option to get through to the [string equal] + if {[regexp {^(name.*|convert.*|)$} $option]} { + return [::interp invokehidden $slave encoding $option {*}$args] } - if {[string first $subcommand system] == 0} { - if {$argc == 1} { + if {[string equal -length [string length $option] $option "system"]} { + if {[llength $args] == 0} { # passed all the tests , lets source it: try { return [::interp invokehidden $slave encoding system] @@ -949,16 +944,17 @@ proc ::safe::AliasEncoding {slave args} { } } set msg "wrong # args: should be \"encoding system\"" + set code {TCL WRONGARGS} } else { - set msg "wrong # args: should be \"encoding option ?arg ...?\"" + set msg "bad option \"$option\": must be convertfrom, convertto, names, or system" + set code [list TCL LOOKUP INDEX option $option] } Log $slave $msg - return -code error $msg + return -code error -errorcode $code $msg } proc ::safe::Setup {} { - #### # # Setup the arguments parsing diff --git a/tests/safe.test b/tests/safe.test index 786cafb..c8e170f 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1,21 +1,21 @@ # 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. +# 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. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# 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.27 2009/11/19 21:17:36 nijtmans Exp $ +# RCS: @(#) $Id: safe.test,v 1.28 2009/12/03 15:49:22 dkf Exp $ package require Tcl 8.5 if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -26,20 +26,19 @@ foreach i [interp slaves] { set saveAutoPath $::auto_path set ::auto_path [info library] -# Force actual loading of the safe package -# because we use un exported (and thus un-autoindexed) APIs -# in this test result arguments: +# 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: + +test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { + safe::interpConfigure +} -result {no value given for parameter "slave" (use -help for full usage) : + slave name () name of the slave} +test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { + safe::interpCreate -help +} -result {Usage information: Var/FlagName Type Value Help ------------ ---- ----- ---- ( -help gives this help ) @@ -49,96 +48,106 @@ test safe-1.2 {safe::interpCreate syntax} { -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}} - + -deleteHook script () delete hook} +test safe-1.3 {safe::interpInit syntax} -returnCodes error -body { + safe::interpInit -noStatics +} -result {bad value "-noStatics" for parameter + slave name () name of the slave} test safe-2.1 {creating interpreters, should have no aliases} emptyTest { # Disabled this test. It tests nothing sensible. [Bug 999612] # interp aliases } "" -test safe-2.2 {creating interpreters, should have no aliases} { +test safe-2.2 {creating interpreters, should have no aliases} -setup { catch {safe::interpDelete a} +} -body { interp create a - set l [a aliases] + a aliases +} -cleanup { safe::interpDelete a - set l -} "" -test safe-2.3 {creating safe interpreters, should have no unexpected aliases} { +} -result "" +test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} +} -body { interp create a -safe - set l [a aliases] + a aliases +} -cleanup { interp delete a - set l -} {clock} +} -result {clock} -test safe-3.1 {calling safe::interpInit is safe} { +test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} - interp create a -safe + interp create a -safe +} -body { safe::interpInit a - catch {interp eval a exec ls} msg + interp eval a exec ls +} -returnCodes error -cleanup { safe::interpDelete a - set msg -} {invalid command name "exec"} -test safe-3.2 {calling safe::interpCreate on trusted interp} { +} -result {invalid command name "exec"} +test safe-3.2 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} +} -body { safe::interpCreate a - set l [lsort [a aliases]] + lsort [a aliases] +} -cleanup { safe::interpDelete a - set l -} {clock encoding exit file glob load source} -test safe-3.3 {calling safe::interpCreate on trusted interp} { +} -result {clock encoding exit file glob load source} +test safe-3.3 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} +} -body { safe::interpCreate a - set x [interp eval a {source [file join $tcl_library init.tcl]}] + interp eval a {source [file join $tcl_library init.tcl]} +} -cleanup { safe::interpDelete a - set x -} "" -test safe-3.4 {calling safe::interpCreate on trusted interp} { +} -result "" +test safe-3.4 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} +} -body { safe::interpCreate a - catch {set x \ - [interp eval a {source [file join $tcl_library init.tcl]}]} msg + interp eval a {source [file join $tcl_library init.tcl]} +} -cleanup { safe::interpDelete a - list $x $msg -} {{} {}} +} -result {} -test safe-4.1 {safe::interpDelete} { +test safe-4.1 {safe::interpDelete} -setup { catch {safe::interpDelete a} +} -body { interp create a safe::interpDelete a -} "" -test safe-4.2 {safe::interpDelete, indirectly} { +} -result "" +test safe-4.2 {safe::interpDelete, indirectly} -setup { catch {safe::interpDelete a} +} -body { interp create a a alias exit safe::interpDelete a a eval exit -} "" -test safe-4.5 {safe::interpDelete} { +} -result "" +test safe-4.5 {safe::interpDelete} -setup { catch {safe::interpDelete a} +} -body { + safe::interpCreate 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} { +} -returnCodes error -cleanup { + safe::interpDelete a +} -result {interpreter named "a" already exists, cannot create} +test safe-4.6 {safe::interpDelete, indirectly} -setup { catch {safe::interpDelete a} +} -body { safe::interpCreate a a eval exit -} "" +} -result "" # 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} { +test safe-5.1 {test auto-loading in safe interpreters} -setup { catch {safe::interpDelete a} safe::interpCreate a - set r [catch {interp eval a {tcl_endOfWord "" 0}} msg] +} -body { + interp eval a {tcl_endOfWord "" 0} +} -cleanup { safe::interpDelete a - list $r $msg -} {0 -1} +} -result -1 # test safe interps 'information leak' proc SafeEval {script} { @@ -198,162 +207,176 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { [safe::interpDelete $i] } -match glob -result "{\$p(:0:)} {\$p(:[expr 1+[llength [tcl::tm::list]]]:)} 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"; +test safe-8.1 {safe source control on file} -setup { + 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 ?-encoding E? fileName"} {}} -test safe-8.2 {safe source control on file} { - set i "a"; +} -body { + safe::interpCreate $i + $i eval {source} +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {wrong # args: should be "source ?-encoding E? fileName"} +test safe-8.2 {safe source control on file} -setup { + 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 ?-encoding E? fileName"} {}} -test safe-8.3 {safe source control on file} { - set i "a"; +} -body { + safe::interpCreate $i + $i eval {source a b c d e} +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {wrong # args: should be "source ?-encoding E? fileName"} +test safe-8.3 {safe source control on file} -setup { + 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"; + set log {} + proc safe-test-log {str} {lappend ::log $str} + set prevlog [safe::setLogCmd] +} -body { + safe::interpCreate $i + safe::setLogCmd safe-test-log + list [catch {$i eval {source .}} msg] $msg $log +} -cleanup { + safe::setLogCmd $prevlog + unset log + safe::interpDelete $i +} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} +test safe-8.4 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} - safe::interpCreate $i; - set log {}; + set log {} proc safe-test-log {str} {global log; lappend log $str} - set prevlog [safe::setLogCmd]; + set prevlog [safe::setLogCmd] +} -body { + safe::interpCreate $i; 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"; + list [catch {$i eval {source /abc/def}} msg] $msg $log +} -cleanup { + safe::setLogCmd $prevlog + unset log + safe::interpDelete $i +} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} +test safe-8.5 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} - safe::interpCreate $i; - set log {}; + 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"; + set prevlog [safe::setLogCmd] +} -body { + # This tested filename == *.tcl or tclIndex, but that restriction was + # removed in 8.4a4 - hobbs + safe::interpCreate $i + safe::setLogCmd safe-test-log + list [catch { + $i eval {source [file join [info lib] blah]} + } msg] $msg $log +} -cleanup { + safe::setLogCmd $prevlog + unset log + safe::interpDelete $i +} -result [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} -setup { + set i "a" catch {safe::interpDelete $i} - safe::interpCreate $i; - set log {}; + 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"; + set prevlog [safe::setLogCmd] +} -body { + safe::interpCreate $i + safe::setLogCmd safe-test-log + list [catch { + $i eval {source [file join [info lib] blah.tcl]} + } msg] $msg $log +} -cleanup { + safe::setLogCmd $prevlog + unset log + safe::interpDelete $i +} -result [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} -setup { + set i "a" catch {safe::interpDelete $i} - safe::interpCreate $i; - set log {}; + 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"; + set prevlog [safe::setLogCmd] +} -body { + safe::interpCreate $i + # This tested length of filename, but that restriction was removed in + # 8.4a4 - hobbs + safe::setLogCmd safe-test-log + list [catch { + $i eval {source [file join [info lib] xxxxxxxxxxx.tcl]} + } msg] $msg $log +} -cleanup { + safe::setLogCmd $prevlog + unset log + safe::interpDelete $i +} -result [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} -setup { + 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 ?-encoding E? fileName"} {}} + safe::interpCreate $i +} -body { + $i eval {source -rsrc Init} +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {wrong # args: should be "source ?-encoding E? fileName"} -test safe-9.1 {safe interps' deleteHook} { - set i "a"; +test safe-9.1 {safe interps' deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} +} -body { proc testDelHook {args} { - global res; + 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; + set res $args } - safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"; + 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"; +} -result {{} {arg1 arg2 a}} +test safe-9.2 {safe interps' error in deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} + set log {} + proc safe-test-log {str} {lappend ::log $str} + set prevlog [safe::setLogCmd] +} -body { proc testDelHook {args} { - global res; + 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; + set res $args # create an exception - error "being catched"; + 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}} + safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" + safe::setLogCmd safe-test-log + list [safe::interpDelete $i] $res $log +} -cleanup { + safe::setLogCmd $prevlog + unset log +} -result {{} {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} -returnCodes error -body { + safe::interpCreate -stat true -nostat +} -result {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.5 {dual specification of nested} -returnCodes error -body { + safe::interpCreate -nested 0 -nestedload +} -result {conflicting values given for -nested and -nestedLoadOk} test safe-9.6 {interpConfigure widget like behaviour} -body { - # this test shall work, don't try to "fix it" unless - # you *really* know what you are doing (ie you are me :p) -- dl + # 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}]; + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar}]; safe::interpConfigure $i -accessPath /foo/bar ; safe::interpConfigure $i]\ [safe::interpConfigure $i -aCCess]\ @@ -366,105 +389,121 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i] } -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}} -# testing that nested and statics do what is advertised -# (we use a static package : Tcltest) - -if {[catch {package require Tcltest} msg]} { - testConstraint TcltestPackage 0 -} else { +# testing that nested and statics do what is advertised (we use a static +# package : Tcltest) +try { + package require Tcltest testConstraint TcltestPackage 1 # we use the Tcltest package , which has no Safe_Init +} on error {} { + testConstraint TcltestPackage 0 } teststaticpkg Safepkg1 0 0 -test safe-10.1 {testing statics loading} TcltestPackage { +test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] - list \ - [catch {interp eval $i {load {} Safepkg1}} msg] \ - $msg \ - [safe::interpDelete $i]; -} {1 {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} {}} -test safe-10.2 {testing statics loading / -nostatics} TcltestPackage { +} -body { + interp eval $i {load {} Safepkg1} +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] - list \ - [catch {interp eval $i {load {} Safepkg1}} msg] \ - $msg \ - [safe::interpDelete $i]; -} {1 {permission denied (static package)} {}} -test safe-10.3 {testing nested statics loading / no nested by default} TcltestPackage { + interp eval $i {load {} Safepkg1} +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {permission denied (static package)} +test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] - list \ - [catch {interp eval $i {interp create x; load {} Safepkg1 x}} msg] \ - $msg \ - [safe::interpDelete $i]; -} {1 {permission denied (nested load)} {}} -test safe-10.4 {testing nested statics loading / -nestedloadok} TcltestPackage { +} -constraints TcltestPackage -body { + interp eval $i {interp create x; load {} Safepkg1 x} +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {permission denied (nested load)} +test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { set i [safe::interpCreate -nestedloadok] - list \ - [catch {interp eval $i {interp create x; load {} Safepkg1 x}} msg] \ - $msg \ - [safe::interpDelete $i]; -} {1 {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} {}} + interp eval $i {interp create x; load {} Safepkg1 x} +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-11.1 {testing safe encoding} { +test safe-11.1 {testing safe encoding} -setup { 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} { +} -body { + interp eval $i encoding +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {wrong # args: should be "encoding option ?arg ...?"} +test safe-11.1a {testing safe encoding} -setup { 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} { +} -body { + interp eval $i encoding foobar +} -returnCodes error -cleanup { + safe::interpDelete $i +} -match glob -result {bad option "foobar": must be *} +test safe-11.2 {testing safe encoding} -setup { 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} { +} -body { + interp eval $i encoding system cp775 +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {wrong # args: should be "encoding system"} +test safe-11.3 {testing safe encoding} -setup { 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} { +} -body { + interp eval $i encoding system +} -cleanup { + safe::interpDelete $i +} -result [encoding system] +test safe-11.4 {testing safe encoding} -setup { 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} { +} -body { + interp eval $i encoding names +} -cleanup { + safe::interpDelete $i +} -result [encoding names] +test safe-11.5 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + interp eval $i encoding convertfrom cp1258 foobar +} -cleanup { + safe::interpDelete $i +} -result foobar +test safe-11.6 {testing safe encoding} -setup { 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} { +} -body { + interp eval $i encoding convertto cp1258 foobar +} -cleanup { + safe::interpDelete $i +} -result foobar +test safe-11.7 {testing safe encoding} -setup { 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} { +} -body { + interp eval $i encoding convertfrom +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test safe-11.8 {testing safe encoding} -setup { 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"} {}} - +} -body { + interp eval $i encoding convertto +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertto ?encoding? data"} +test safe-12.1 {glob is restricted [Bug 2906841]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob ../* +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result "permission denied" + set ::auto_path $saveAutoPath # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12