summaryrefslogtreecommitdiffstats
path: root/tests/safe.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/safe.test')
-rw-r--r--tests/safe.test179
1 files changed, 105 insertions, 74 deletions
diff --git a/tests/safe.test b/tests/safe.test
index 3e9f716..652e1a2 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -1,14 +1,15 @@
-# This file is a Tcl script to test the Safe Tk facility. It is organized
-# in the standard fashion for Tk tests.
+# This file is a Tcl script to test the Safe Tk facility. It is organized in
+# the standard fashion for Tk tests.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-package require tcltest 2.1
+package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
+namespace import -force tcltest::test
## NOTE: Any time tests fail here with an error like:
@@ -27,144 +28,167 @@ tcltest::loadTestedCommands
# This probably means that tk wasn't installed properly.
## it indicates that something went wrong sourcing tk.tcl.
-## Ensure that any changes that occured to tk.tcl will work or
-## are properly prevented in a safe interpreter. -- hobbs
+## Ensure that any changes that occured to tk.tcl will work or are properly
+## prevented in a safe interpreter. -- hobbs
# The set of hidden commands is platform dependent:
-if {[string equal $tcl_platform(platform) "windows"]} {
- set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile tk_messageBox toplevel unload wm}
+set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source toplevel unload wm}
+lappend hidden_cmds {*}[apply {{} {
+ foreach cmd {
+ atime attributes copy delete dirname executable exists extension
+ isdirectory isfile link lstat mkdir mtime nativename normalize owned
+ readable readlink rename rootname size stat tail tempfile type
+ volumes writable
+ } {lappend result tcl:file:$cmd}; return $result
+}}]
+if {$tcl_platform(platform) eq "windows"} {
+ lappend hidden_cmds tk_chooseColor tk_chooseDirectory tk_getOpenFile \
+ tk_getSaveFile tk_messageBox
} else {
- set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel unload wm}
+ lappend hidden_cmds send
}
set saveAutoPath $::auto_path
set auto_path [list [info library] $::tk_library]
-
-test safe-1.1 {Safe Tk loading into an interpreter} {
+set hidden_cmds [lsort $hidden_cmds]
+
+test safe-1.1 {Safe Tk loading into an interpreter} -setup {
catch {safe::interpDelete a}
+} -body {
safe::loadTk [safe::interpCreate a]
safe::interpDelete a
set x {}
- set x
-} ""
-test safe-1.2 {Safe Tk loading into an interpreter} {
+ return $x
+} -result {}
+test safe-1.2 {Safe Tk loading into an interpreter} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
- set l [lsort [interp hidden a]]
+ lsort [interp hidden a]
+} -cleanup {
safe::interpDelete a
- set l
-} $hidden_cmds
-test safe-1.3 {Safe Tk loading into an interpreter} -body {
+} -result $hidden_cmds
+test safe-1.3 {Safe Tk loading into an interpreter} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
- set l [lsort [interp aliases a]]
+ lsort [interp aliases a]
+} -cleanup {
safe::interpDelete a
- set l
} -match glob -result {*encoding*exit*file*load*source*}
-test safe-2.1 {Unsafe commands not available} {
+test safe-2.1 {Unsafe commands not available} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {toplevel .t}} msg]} {
set status ok
}
+ return $status
+} -cleanup {
safe::interpDelete a
- set status
-} ok
-test safe-2.2 {Unsafe commands not available} {
+} -result ok
+test safe-2.2 {Unsafe commands not available} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {menu .m}} msg]} {
set status ok
}
+ return $status
+} -cleanup {
safe::interpDelete a
- set status
-} ok
-test safe-2.3 {Unsafe subcommands not available} {
+} -result ok
+test safe-2.3 {Unsafe subcommands not available} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {tk appname}} msg]} {
set status ok
}
- safe::interpDelete a
list $status $msg
-} {ok {appname not accessible in a safe interpreter}}
-test safe-2.4 {Unsafe subcommands not available} {
+} -cleanup {
+ safe::interpDelete a
+} -result {ok {appname not accessible in a safe interpreter}}
+test safe-2.4 {Unsafe subcommands not available} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
set status broken
if {[catch {interp eval a {tk scaling}} msg]} {
set status ok
}
- safe::interpDelete a
list $status $msg
-} {ok {scaling not accessible in a safe interpreter}}
+} -cleanup {
+ safe::interpDelete a
+} -result {ok {scaling not accessible in a safe interpreter}}
-test safe-3.1 {Unsafe commands are available hidden} {
+test safe-3.1 {Unsafe commands are available hidden} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
set status ok
if {[catch {interp invokehidden a toplevel .t} msg]} {
set status broken
}
+ return $status
+} -cleanup {
safe::interpDelete a
- set status
-} ok
-test safe-3.2 {Unsafe commands are available hidden} {
+} -result ok
+test safe-3.2 {Unsafe commands are available hidden} -setup {
catch {safe::interpDelete a}
+} -body {
safe::interpCreate a
safe::loadTk a
set status ok
if {[catch {interp invokehidden a menu .m} msg]} {
set status broken
}
+ return $status
+} -cleanup {
safe::interpDelete a
- set status
-} ok
+} -result ok
-test safe-4.1 {testing loadTk} {
- # no error shall occur, the user will
- # eventually see a new toplevel
+test safe-4.1 {testing loadTk} -body {
+ # no error shall occur, the user will eventually see a new toplevel
set i [safe::loadTk [safe::interpCreate]]
interp eval $i {button .b -text "hello world!"; pack .b}
- # lets don't update because it might imply that the user has
- # to position the window (if the wm does not do it automatically)
- # and thus make the test suite not runable non interactively
+ # lets don't update because it might imply that the user has to position
+ # the window (if the wm does not do it automatically) and thus make the
+ # test suite not runable non interactively
safe::interpDelete $i
-} {}
-
-test safe-4.2 {testing loadTk -use} {
+} -result {}
+test safe-4.2 {testing loadTk -use} -setup {
+ destroy .safeTkFrame
+} -body {
set w .safeTkFrame
- catch {destroy $w}
frame $w -container 1;
- pack .safeTkFrame
+ pack $w
set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]]
interp eval $i {button .b -text "hello world!"; pack .b}
safe::interpDelete $i
destroy $w
-} {}
+} -result {}
-test safe-5.1 {loading Tk in safe interps without master's clearance} {
+test safe-5.1 {loading Tk in safe interps without master's clearance} -body {
set i [safe::interpCreate]
- catch {interp eval $i {load {} Tk}} msg
+ interp eval $i {load {} Tk}
+} -cleanup {
safe::interpDelete $i
- set msg
-} {not allowed to start Tk by master's safe::TkInit}
-
-test safe-5.2 {multi-level Tk loading with clearance} {
- # No error shall occur in that test and no window
- # shall remain at the end.
+} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit}
+test safe-5.2 {multi-level Tk loading with clearance} -body {
+ # No error shall occur in that test and no window shall remain at the end.
set i [safe::interpCreate]
set j [list $i x]
set j [safe::interpCreate $j]
@@ -174,43 +198,50 @@ test safe-5.2 {multi-level Tk loading with clearance} {
pack .b
# tkwait window . ; # for interactive testing/debugging
}
+} -cleanup {
safe::interpDelete $j
safe::interpDelete $i
-} {}
+} -result {}
-test safe-6.1 {loadTk -use windowPath} {
+test safe-6.1 {loadTk -use windowPath} -setup {
+ destroy .safeTkFrame
+} -body {
set w .safeTkFrame
- catch {destroy $w}
frame $w -container 1;
- pack .safeTkFrame
+ pack $w
set i [safe::loadTk [safe::interpCreate] -use $w]
interp eval $i {button .b -text "hello world!"; pack .b}
safe::interpDelete $i
destroy $w
-} {}
-
-test safe-6.2 {loadTk -use windowPath, conflicting -display} {
+} -result {}
+test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup {
+ destroy .safeTkFrame
+} -body {
set w .safeTkFrame
- catch {destroy $w}
frame $w -container 1;
- pack .safeTkFrame
+ pack $w
set i [safe::interpCreate]
catch {safe::loadTk $i -use $w -display :23.56} msg
+ string range $msg 0 36
+} -cleanup {
safe::interpDelete $i
destroy $w
- string range $msg 0 36
-} {conflicting -display :23.56 and -use }
+} -result {conflicting -display :23.56 and -use }
-
-test safe-7.1 {canvas printing} {
+test safe-7.1 {canvas printing} -body {
set i [safe::loadTk [safe::interpCreate]]
- set r [catch {interp eval $i {canvas .c; .c postscript}}]
+ interp eval $i {canvas .c; .c postscript}
+} -cleanup {
safe::interpDelete $i
- set r
-} 0
-
+} -returnCodes ok -match glob -result *
+
# cleanup
set ::auto_path $saveAutoPath
unset hidden_cmds
cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End: