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