# 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. # # RCS: @(#) $Id: safe.test,v 1.10.2.1 2004/10/26 23:23:13 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] 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 {"$tcl_platform(platform)" == "macintosh"} { set hidden_cmds {beep bell cd clipboard echo encoding exit fconfigure file glob grab load ls menu open pwd selection send socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile toplevel wm} } elseif {"$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 wm} } else { set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel wm} } 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 unset hidden_cmds ::tcltest::cleanupTests return