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