264 lines
7.4 KiB
Plaintext
264 lines
7.4 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.2
|
||
eval tcltest::configure $argv
|
||
tcltest::loadTestedCommands
|
||
namespace import -force tcltest::test
|
||
|
||
## 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 occurred to tk.tcl will work or are properly
|
||
## prevented in a safe interpreter. -- hobbs
|
||
|
||
# The set of hidden commands is platform dependent:
|
||
|
||
set hidden_cmds [list bell cd clipboard encoding exec exit \
|
||
fconfigure glob grab load menu open pwd selection \
|
||
socket source toplevel unload wm]
|
||
if {[package vsatisfies [package provide Tcl] 8.6.7-]} {
|
||
lappend hidden_cmds tcl:encoding:dirs
|
||
}
|
||
if {[package vsatisfies [package provide Tcl] 8.7-]} {
|
||
lappend hidden_cmds file tcl:encoding:system tcl:file:tempdir
|
||
foreach cmd {
|
||
cmdtype nameofexecutable
|
||
} {lappend hidden_cmds tcl:info:$cmd}
|
||
foreach cmd {
|
||
autopurge list purge status
|
||
} {lappend hidden_cmds tcl:process:$cmd}
|
||
foreach cmd {
|
||
lmkimg lmkzip mkimg mkkey mkzip mount mount_data unmount
|
||
} {lappend hidden_cmds tcl:zipfs:$cmd}
|
||
}
|
||
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 hidden_cmds tcl:file:$cmd}
|
||
if {[tk windowingsystem] ne "x11"} {
|
||
lappend hidden_cmds tk_chooseColor tk_chooseDirectory \
|
||
tk_getOpenFile tk_getSaveFile tk_messageBox
|
||
}
|
||
if {[llength [info commands send]]} {
|
||
lappend hidden_cmds send
|
||
}
|
||
|
||
set saveAutoPath $::auto_path
|
||
set auto_path [list [info library] $::tk_library]
|
||
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 {}
|
||
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
|
||
lsort [interp hidden a]
|
||
} -cleanup {
|
||
safe::interpDelete a
|
||
} -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
|
||
lsort [interp aliases a]
|
||
} -cleanup {
|
||
safe::interpDelete a
|
||
} -match glob -result {*encoding*exit*glob*load*source*}
|
||
|
||
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
|
||
} -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
|
||
} -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
|
||
}
|
||
list $status $msg
|
||
} -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
|
||
}
|
||
list $status $msg
|
||
} -cleanup {
|
||
safe::interpDelete a
|
||
} -result {ok {scaling not accessible in a safe interpreter}}
|
||
|
||
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
|
||
} -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
|
||
} -result ok
|
||
|
||
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
|
||
safe::interpDelete $i
|
||
} -result {}
|
||
test safe-4.2 {testing loadTk -use} -setup {
|
||
destroy .safeTkFrame
|
||
} -body {
|
||
set w .safeTkFrame
|
||
frame $w -container 1;
|
||
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 parent's clearance} -body {
|
||
set i [safe::interpCreate]
|
||
interp eval $i {load {} Tk}
|
||
} -cleanup {
|
||
safe::interpDelete $i
|
||
} -returnCodes error -match glob -result {*not allowed}
|
||
test safe-5.2 {multi-level Tk loading with clearance} -setup {
|
||
set safeParent [safe::interpCreate]
|
||
} -body {
|
||
# No error shall occur in that test and no window shall remain at the end.
|
||
set i [safe::interpCreate [list $safeParent x]]
|
||
safe::loadTk $i
|
||
interp eval $i {
|
||
button .b -text Ok -command {destroy .}
|
||
pack .b
|
||
# tkwait window . ; # for interactive testing/debugging
|
||
}
|
||
} -cleanup {
|
||
catch {safe::interpDelete $i}
|
||
safe::interpDelete $safeParent
|
||
} -result {}
|
||
|
||
test safe-6.1 {loadTk -use windowPath} -setup {
|
||
destroy .safeTkFrame
|
||
} -body {
|
||
set w .safeTkFrame
|
||
frame $w -container 1;
|
||
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
|
||
} -result {}
|
||
test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup {
|
||
destroy .safeTkFrame
|
||
} -body {
|
||
set w .safeTkFrame
|
||
frame $w -container 1;
|
||
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
|
||
} -result {conflicting -display :23.56 and -use }
|
||
|
||
test safe-7.1 {canvas printing} -body {
|
||
set i [safe::loadTk [safe::interpCreate]]
|
||
interp eval $i {canvas .c; .c postscript}
|
||
} -cleanup {
|
||
safe::interpDelete $i
|
||
} -returnCodes ok -match glob -result *
|
||
|
||
# cleanup
|
||
set ::auto_path $saveAutoPath
|
||
unset hidden_cmds
|
||
cleanupTests
|
||
return
|
||
|
||
# Local Variables:
|
||
# mode: tcl
|
||
# fill-column: 78
|
||
# End:
|