1# This file is a Tcl script to test the Safe Tk facility. It is organized 2# in the standard fashion for Tk tests. 3# 4# Copyright (c) 1994 The Regents of the University of California. 5# Copyright (c) 1994-1995 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8# 9# RCS: @(#) $Id: safe.test,v 1.10.2.2 2005/06/06 22:46:51 dgp Exp $ 10 11package require tcltest 2.1 12namespace import -force tcltest::configure 13namespace import -force tcltest::testsDirectory 14configure -testdir [file join [pwd] [file dirname [info script]]] 15configure -loadfile [file join [testsDirectory] constraints.tcl] 16tcltest::loadTestedCommands 17 18## NOTE: Any time tests fail here with an error like: 19 20# Can't find a usable tk.tcl in the following directories: 21# {$p(:26:)} 22# 23# $p(:26:)/tk.tcl: script error 24# script error 25# invoked from within 26# "source {$p(:26:)/tk.tcl}" 27# ("uplevel" body line 1) 28# invoked from within 29# "uplevel #0 [list source $file]" 30# 31# 32# This probably means that tk wasn't installed properly. 33 34## it indicates that something went wrong sourcing tk.tcl. 35## Ensure that any changes that occured to tk.tcl will work or 36## are properly prevented in a safe interpreter. -- hobbs 37 38# The set of hidden commands is platform dependent: 39 40if {"$tcl_platform(platform)" == "macintosh"} { 41 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} 42} elseif {"$tcl_platform(platform)" == "windows"} { 43 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} 44} else { 45 set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel wm} 46} 47 48set saveAutoPath $::auto_path 49set ::auto_path [list [info library] $::tk_library] 50 51test safe-1.1 {Safe Tk loading into an interpreter} { 52 catch {safe::interpDelete a} 53 safe::loadTk [safe::interpCreate a] 54 safe::interpDelete a 55 set x {} 56 set x 57} "" 58test safe-1.2 {Safe Tk loading into an interpreter} { 59 catch {safe::interpDelete a} 60 safe::interpCreate a 61 safe::loadTk a 62 set l [lsort [interp hidden a]] 63 safe::interpDelete a 64 set l 65} $hidden_cmds 66test safe-1.3 {Safe Tk loading into an interpreter} -body { 67 catch {safe::interpDelete a} 68 safe::interpCreate a 69 safe::loadTk a 70 set l [lsort [interp aliases a]] 71 safe::interpDelete a 72 set l 73} -match glob -result {*encoding*exit*file*load*source*} 74 75test safe-2.1 {Unsafe commands not available} { 76 catch {safe::interpDelete a} 77 safe::interpCreate a 78 safe::loadTk a 79 set status broken 80 if {[catch {interp eval a {toplevel .t}} msg]} { 81 set status ok 82 } 83 safe::interpDelete a 84 set status 85} ok 86test safe-2.2 {Unsafe commands not available} { 87 catch {safe::interpDelete a} 88 safe::interpCreate a 89 safe::loadTk a 90 set status broken 91 if {[catch {interp eval a {menu .m}} msg]} { 92 set status ok 93 } 94 safe::interpDelete a 95 set status 96} ok 97test safe-2.3 {Unsafe subcommands not available} { 98 catch {safe::interpDelete a} 99 safe::interpCreate a 100 safe::loadTk a 101 set status broken 102 if {[catch {interp eval a {tk appname}} msg]} { 103 set status ok 104 } 105 safe::interpDelete a 106 list $status $msg 107} {ok {appname not accessible in a safe interpreter}} 108test safe-2.4 {Unsafe subcommands not available} { 109 catch {safe::interpDelete a} 110 safe::interpCreate a 111 safe::loadTk a 112 set status broken 113 if {[catch {interp eval a {tk scaling}} msg]} { 114 set status ok 115 } 116 safe::interpDelete a 117 list $status $msg 118} {ok {scaling not accessible in a safe interpreter}} 119 120test safe-3.1 {Unsafe commands are available hidden} { 121 catch {safe::interpDelete a} 122 safe::interpCreate a 123 safe::loadTk a 124 set status ok 125 if {[catch {interp invokehidden a toplevel .t} msg]} { 126 set status broken 127 } 128 safe::interpDelete a 129 set status 130} ok 131test safe-3.2 {Unsafe commands are available hidden} { 132 catch {safe::interpDelete a} 133 safe::interpCreate a 134 safe::loadTk a 135 set status ok 136 if {[catch {interp invokehidden a menu .m} msg]} { 137 set status broken 138 } 139 safe::interpDelete a 140 set status 141} ok 142 143test safe-4.1 {testing loadTk} { 144 # no error shall occur, the user will 145 # eventually see a new toplevel 146 set i [safe::loadTk [safe::interpCreate]] 147 interp eval $i {button .b -text "hello world!"; pack .b} 148 # lets don't update because it might imply that the user has 149 # to position the window (if the wm does not do it automatically) 150 # and thus make the test suite not runable non interactively 151 safe::interpDelete $i 152} {} 153 154test safe-4.2 {testing loadTk -use} { 155 set w .safeTkFrame 156 catch {destroy $w} 157 frame $w -container 1; 158 pack .safeTkFrame 159 set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]] 160 interp eval $i {button .b -text "hello world!"; pack .b} 161 safe::interpDelete $i 162 destroy $w 163} {} 164 165test safe-5.1 {loading Tk in safe interps without master's clearance} { 166 set i [safe::interpCreate] 167 catch {interp eval $i {load {} Tk}} msg 168 safe::interpDelete $i 169 set msg 170} {not allowed to start Tk by master's safe::TkInit} 171 172test safe-5.2 {multi-level Tk loading with clearance} { 173 # No error shall occur in that test and no window 174 # shall remain at the end. 175 set i [safe::interpCreate] 176 set j [list $i x] 177 set j [safe::interpCreate $j] 178 safe::loadTk $j 179 interp eval $j { 180 button .b -text Ok -command {destroy .} 181 pack .b 182# tkwait window . ; # for interactive testing/debugging 183 } 184 safe::interpDelete $j 185 safe::interpDelete $i 186} {} 187 188test safe-6.1 {loadTk -use windowPath} { 189 set w .safeTkFrame 190 catch {destroy $w} 191 frame $w -container 1; 192 pack .safeTkFrame 193 set i [safe::loadTk [safe::interpCreate] -use $w] 194 interp eval $i {button .b -text "hello world!"; pack .b} 195 safe::interpDelete $i 196 destroy $w 197} {} 198 199test safe-6.2 {loadTk -use windowPath, conflicting -display} { 200 set w .safeTkFrame 201 catch {destroy $w} 202 frame $w -container 1; 203 pack .safeTkFrame 204 set i [safe::interpCreate] 205 catch {safe::loadTk $i -use $w -display :23.56} msg 206 safe::interpDelete $i 207 destroy $w 208 string range $msg 0 36 209} {conflicting -display :23.56 and -use } 210 211 212test safe-7.1 {canvas printing} { 213 set i [safe::loadTk [safe::interpCreate]] 214 set r [catch {interp eval $i {canvas .c; .c postscript}}] 215 safe::interpDelete $i 216 set r 217} 0 218 219# cleanup 220set ::auto_path $saveAutoPath 221unset hidden_cmds 222::tcltest::cleanupTests 223return 224