217 lines
6.1 KiB
Plaintext
217 lines
6.1 KiB
Plaintext
# 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
|
|
eval tcltest::configure $argv
|
|
tcltest::loadTestedCommands
|
|
|
|
## NOTE: Any time tests fail here with an error like:
|
|
|
|
# Can't find a usable tk.tcl in the following directories:
|
|
# {$p(:26:)}
|
|
#
|
|
# $p(:26:)/tk.tcl: script error
|
|
# script error
|
|
# invoked from within
|
|
# "source {$p(:26:)/tk.tcl}"
|
|
# ("uplevel" body line 1)
|
|
# invoked from within
|
|
# "uplevel #0 [list source $file]"
|
|
#
|
|
#
|
|
# 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
|
|
|
|
# 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}
|
|
} 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}
|
|
}
|
|
|
|
set saveAutoPath $::auto_path
|
|
set auto_path [list [info library] $::tk_library]
|
|
|
|
test safe-1.1 {Safe Tk loading into an interpreter} {
|
|
catch {safe::interpDelete a}
|
|
safe::loadTk [safe::interpCreate a]
|
|
safe::interpDelete a
|
|
set x {}
|
|
set x
|
|
} ""
|
|
test safe-1.2 {Safe Tk loading into an interpreter} {
|
|
catch {safe::interpDelete a}
|
|
safe::interpCreate a
|
|
safe::loadTk a
|
|
set l [lsort [interp hidden a]]
|
|
safe::interpDelete a
|
|
set l
|
|
} $hidden_cmds
|
|
test safe-1.3 {Safe Tk loading into an interpreter} -body {
|
|
catch {safe::interpDelete a}
|
|
safe::interpCreate a
|
|
safe::loadTk a
|
|
set l [lsort [interp aliases a]]
|
|
safe::interpDelete a
|
|
set l
|
|
} -match glob -result {*encoding*exit*file*load*source*}
|
|
|
|
test safe-2.1 {Unsafe commands not available} {
|
|
catch {safe::interpDelete a}
|
|
safe::interpCreate a
|
|
safe::loadTk a
|
|
set status broken
|
|
if {[catch {interp eval a {toplevel .t}} msg]} {
|
|
set status ok
|
|
}
|
|
safe::interpDelete a
|
|
set status
|
|
} ok
|
|
test safe-2.2 {Unsafe commands not available} {
|
|
catch {safe::interpDelete a}
|
|
safe::interpCreate a
|
|
safe::loadTk a
|
|
set status broken
|
|
if {[catch {interp eval a {menu .m}} msg]} {
|
|
set status ok
|
|
}
|
|
safe::interpDelete a
|
|
set status
|
|
} ok
|
|
test safe-2.3 {Unsafe subcommands not available} {
|
|
catch {safe::interpDelete a}
|
|
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} {
|
|
catch {safe::interpDelete a}
|
|
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}}
|
|
|
|
test safe-3.1 {Unsafe commands are available hidden} {
|
|
catch {safe::interpDelete a}
|
|
safe::interpCreate a
|
|
safe::loadTk a
|
|
set status ok
|
|
if {[catch {interp invokehidden a toplevel .t} msg]} {
|
|
set status broken
|
|
}
|
|
safe::interpDelete a
|
|
set status
|
|
} ok
|
|
test safe-3.2 {Unsafe commands are available hidden} {
|
|
catch {safe::interpDelete a}
|
|
safe::interpCreate a
|
|
safe::loadTk a
|
|
set status ok
|
|
if {[catch {interp invokehidden a menu .m} msg]} {
|
|
set status broken
|
|
}
|
|
safe::interpDelete a
|
|
set status
|
|
} ok
|
|
|
|
test safe-4.1 {testing loadTk} {
|
|
# 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
|
|
safe::interpDelete $i
|
|
} {}
|
|
|
|
test safe-4.2 {testing loadTk -use} {
|
|
set w .safeTkFrame
|
|
catch {destroy $w}
|
|
frame $w -container 1;
|
|
pack .safeTkFrame
|
|
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
|
|
} {}
|
|
|
|
test safe-5.1 {loading Tk in safe interps without master's clearance} {
|
|
set i [safe::interpCreate]
|
|
catch {interp eval $i {load {} Tk}} msg
|
|
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.
|
|
set i [safe::interpCreate]
|
|
set j [list $i x]
|
|
set j [safe::interpCreate $j]
|
|
safe::loadTk $j
|
|
interp eval $j {
|
|
button .b -text Ok -command {destroy .}
|
|
pack .b
|
|
# tkwait window . ; # for interactive testing/debugging
|
|
}
|
|
safe::interpDelete $j
|
|
safe::interpDelete $i
|
|
} {}
|
|
|
|
test safe-6.1 {loadTk -use windowPath} {
|
|
set w .safeTkFrame
|
|
catch {destroy $w}
|
|
frame $w -container 1;
|
|
pack .safeTkFrame
|
|
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} {
|
|
set w .safeTkFrame
|
|
catch {destroy $w}
|
|
frame $w -container 1;
|
|
pack .safeTkFrame
|
|
set i [safe::interpCreate]
|
|
catch {safe::loadTk $i -use $w -display :23.56} msg
|
|
safe::interpDelete $i
|
|
destroy $w
|
|
string range $msg 0 36
|
|
} {conflicting -display :23.56 and -use }
|
|
|
|
|
|
test safe-7.1 {canvas printing} {
|
|
set i [safe::loadTk [safe::interpCreate]]
|
|
set r [catch {interp eval $i {canvas .c; .c postscript}}]
|
|
safe::interpDelete $i
|
|
set r
|
|
} 0
|
|
|
|
# cleanup
|
|
set ::auto_path $saveAutoPath
|
|
unset hidden_cmds
|
|
cleanupTests
|
|
return
|