tk/tests/safe.test

   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
  11 package require tcltest 2.1
  12 namespace import -force tcltest::configure
  13 namespace import -force tcltest::testsDirectory
  14 configure -testdir [file join [pwd] [file dirname [info script]]]
  15 configure -loadfile [file join [testsDirectory] constraints.tcl]
  16 tcltest::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
  40 if {"$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
  48 test safe-1.1 {Safe Tk loading into an interpreter} {
  49     catch {safe::interpDelete a}
  50     safe::loadTk [safe::interpCreate a]
  51     safe::interpDelete a
  52     set x {}
  53     set x
  54 } ""
  55 test safe-1.2 {Safe Tk loading into an interpreter} {
  56     catch {safe::interpDelete a}
  57     safe::interpCreate a
  58     safe::loadTk a
  59     set l [lsort [interp hidden a]]
  60     safe::interpDelete a
  61     set l
  62 } $hidden_cmds
  63 test safe-1.3 {Safe Tk loading into an interpreter} {
  64     catch {safe::interpDelete a}
  65     safe::interpCreate a
  66     safe::loadTk a
  67     set l [lsort [interp aliases a]]
  68     safe::interpDelete a
  69     set l
  70 } {encoding exit file load source}
  71
  72 test safe-2.1 {Unsafe commands not available} {
  73     catch {safe::interpDelete a}
  74     safe::interpCreate a
  75     safe::loadTk a
  76     set status broken
  77     if {[catch {interp eval a {toplevel .t}} msg]} {
  78         set status ok
  79     }
  80     safe::interpDelete a
  81     set status
  82 } ok
  83 test safe-2.2 {Unsafe commands not available} {
  84     catch {safe::interpDelete a}
  85     safe::interpCreate a
  86     safe::loadTk a
  87     set status broken
  88     if {[catch {interp eval a {menu .m}} msg]} {
  89         set status ok
  90     }
  91     safe::interpDelete a
  92     set status
  93 } ok
  94 test safe-2.3 {Unsafe subcommands not available} {
  95     catch {safe::interpDelete a}
  96     safe::interpCreate a
  97     safe::loadTk a
  98     set status broken
  99     if {[catch {interp eval a {tk appname}} msg]} {
 100         set status ok
 101     }
 102     safe::interpDelete a
 103     list $status $msg
 104 } {ok {appname not accessible in a safe interpreter}}
 105 test safe-2.4 {Unsafe subcommands not available} {
 106     catch {safe::interpDelete a}
 107     safe::interpCreate a
 108     safe::loadTk a
 109     set status broken
 110     if {[catch {interp eval a {tk scaling}} msg]} {
 111         set status ok
 112     }
 113     safe::interpDelete a
 114     list $status $msg
 115 } {ok {scaling not accessible in a safe interpreter}}
 116
 117 test safe-3.1 {Unsafe commands are available hidden} {
 118     catch {safe::interpDelete a}
 119     safe::interpCreate a
 120     safe::loadTk a
 121     set status ok
 122     if {[catch {interp invokehidden a toplevel .t} msg]} {
 123         set status broken
 124     }
 125     safe::interpDelete a
 126     set status
 127 } ok
 128 test safe-3.2 {Unsafe commands are available hidden} {
 129     catch {safe::interpDelete a}
 130     safe::interpCreate a
 131     safe::loadTk a
 132     set status ok
 133     if {[catch {interp invokehidden a menu .m} msg]} {
 134         set status broken
 135     }
 136     safe::interpDelete a
 137     set status
 138 } ok
 139
 140 test safe-4.1 {testing loadTk} {
 141     # no error shall occur, the user will
 142     # eventually see a new toplevel
 143     set i [safe::loadTk [safe::interpCreate]]
 144     interp eval $i {button .b -text "hello world!"; pack .b}
 145     # lets don't update because it might imply that the user has
 146     # to position the window (if the wm does not do it automatically)
 147     # and thus make the test suite not runable non interactively
 148     safe::interpDelete $i
 149 } {}
 150
 151 test safe-4.2 {testing loadTk -use} {
 152     set w .safeTkFrame
 153     catch {destroy $w}
 154     frame $w -container 1;
 155     pack .safeTkFrame
 156     set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]]
 157     interp eval $i {button .b -text "hello world!"; pack .b}
 158     safe::interpDelete $i
 159     destroy $w
 160 } {}
 161
 162 test safe-5.1 {loading Tk in safe interps without master's clearance} {
 163     set i [safe::interpCreate]
 164     catch {interp eval $i {load {} Tk}} msg
 165     safe::interpDelete $i
 166     set msg
 167 } {not allowed to start Tk by master's safe::TkInit}
 168
 169 test safe-5.2 {multi-level Tk loading with clearance} {
 170     # No error shall occur in that test and no window
 171     # shall remain at the end.
 172     set i [safe::interpCreate]
 173     set j [list $i x]
 174     set j [safe::interpCreate $j]
 175     safe::loadTk $j
 176     interp eval $j {
 177         button .b -text Ok -command {destroy .}
 178         pack .b
 179 #       tkwait window . ; # for interactive testing/debugging
 180     }
 181     safe::interpDelete $j
 182     safe::interpDelete $i
 183 } {}
 184
 185 test safe-6.1 {loadTk -use windowPath} {
 186     set w .safeTkFrame
 187     catch {destroy $w}
 188     frame $w -container 1;
 189     pack .safeTkFrame
 190     set i [safe::loadTk [safe::interpCreate] -use $w]
 191     interp eval $i {button .b -text "hello world!"; pack .b}
 192     safe::interpDelete $i
 193     destroy $w
 194 } {}
 195
 196 test safe-6.2 {loadTk -use windowPath, conflicting -display} {
 197     set w .safeTkFrame
 198     catch {destroy $w}
 199     frame $w -container 1;
 200     pack .safeTkFrame
 201     set i     [safe::interpCreate]
 202     catch {safe::loadTk $i -use $w -display :23.56} msg
 203     safe::interpDelete $i
 204     destroy $w
 205     string range $msg 0 36
 206 } {conflicting -display :23.56 and -use }
 207
 208
 209 test safe-7.1 {canvas printing} {
 210     set i [safe::loadTk [safe::interpCreate]]
 211     set r [catch {interp eval $i {canvas .c; .c postscript}}]
 212     safe::interpDelete $i
 213     set r
 214 } 0
 215
 216 # cleanup
 217 unset hidden_cmds
 218 ::tcltest::cleanupTests
 219 return