1# This file is a Tcl script to test the Safe Tk facility. It is organized in
2# the standard fashion for Tk tests.
3#
4# Copyright © 1994 The Regents of the University of California.
5# Copyright © 1994-1995 Sun Microsystems, Inc.
6# Copyright © 1998-1999 Scriptics Corporation.
7# All rights reserved.
8
9package require tcltest 2.2
10eval tcltest::configure $argv
11tcltest::loadTestedCommands
12namespace import -force tcltest::test
13
14## NOTE: Any time tests fail here with an error like:
15
16# Can't find a usable tk.tcl in the following directories:
17#     {$p(:26:)}
18#
19# $p(:26:)/tk.tcl: script error
20# script error
21#     invoked from within
22# "source {$p(:26:)/tk.tcl}"
23#     ("uplevel" body line 1)
24#     invoked from within
25# "uplevel #0 [list source $file]"
26#
27#
28# This probably means that tk wasn't installed properly.
29
30## it indicates that something went wrong sourcing tk.tcl.
31## Ensure that any changes that occurred to tk.tcl will work or are properly
32## prevented in a safe interpreter.  -- hobbs
33
34# The set of hidden commands is platform dependent:
35
36set hidden_cmds [list bell cd clipboard encoding exec exit \
37	fconfigure glob grab load menu open pwd selection \
38	socket source toplevel unload wm]
39if {[package vsatisfies [package provide Tcl] 8.6.7-]} {
40    lappend hidden_cmds tcl:encoding:dirs
41}
42if {[package vsatisfies [package provide Tcl] 8.7-]} {
43    lappend hidden_cmds file tcl:encoding:system tcl:file:tempdir
44    foreach cmd {
45	cmdtype nameofexecutable
46    } {lappend hidden_cmds tcl:info:$cmd}
47    foreach cmd {
48	autopurge list purge status
49    } {lappend hidden_cmds tcl:process:$cmd}
50    foreach cmd {
51	lmkimg lmkzip mkimg mkkey mkzip mount  mount_data unmount
52    } {lappend hidden_cmds tcl:zipfs:$cmd}
53}
54foreach cmd {
55    atime attributes copy delete dirname executable exists extension
56    isdirectory isfile link lstat mkdir mtime nativename normalize
57    owned readable readlink rename rootname size stat tail tempfile
58    type volumes writable
59} {lappend hidden_cmds tcl:file:$cmd}
60if {[tk windowingsystem] ne "x11"} {
61    lappend hidden_cmds tk_chooseColor tk_chooseDirectory \
62	tk_getOpenFile tk_getSaveFile tk_messageBox
63}
64if {[llength [info commands send]]} {
65    lappend hidden_cmds send
66}
67
68set saveAutoPath $::auto_path
69set auto_path [list [info library] $::tk_library]
70set hidden_cmds [lsort $hidden_cmds]
71
72test safe-1.1 {Safe Tk loading into an interpreter} -setup {
73    catch {safe::interpDelete a}
74} -body {
75    safe::loadTk [safe::interpCreate a]
76    safe::interpDelete a
77    set x {}
78    return $x
79} -result {}
80test safe-1.2 {Safe Tk loading into an interpreter} -setup {
81    catch {safe::interpDelete a}
82} -body {
83    safe::interpCreate a
84    safe::loadTk a
85    lsort [interp hidden a]
86} -cleanup {
87    safe::interpDelete a
88} -result $hidden_cmds
89test safe-1.3 {Safe Tk loading into an interpreter} -setup {
90    catch {safe::interpDelete a}
91} -body {
92    safe::interpCreate a
93    safe::loadTk a
94    lsort [interp aliases a]
95} -cleanup {
96    safe::interpDelete a
97} -match glob -result {*encoding*exit*glob*load*source*}
98
99test safe-2.1 {Unsafe commands not available} -setup {
100    catch {safe::interpDelete a}
101} -body {
102    safe::interpCreate a
103    safe::loadTk a
104    set status broken
105    if {[catch {interp eval a {toplevel .t}} msg]} {
106	set status ok
107    }
108    return $status
109} -cleanup {
110    safe::interpDelete a
111} -result ok
112test safe-2.2 {Unsafe commands not available} -setup {
113    catch {safe::interpDelete a}
114} -body {
115    safe::interpCreate a
116    safe::loadTk a
117    set status broken
118    if {[catch {interp eval a {menu .m}} msg]} {
119	set status ok
120    }
121    return $status
122} -cleanup {
123    safe::interpDelete a
124} -result ok
125test safe-2.3 {Unsafe subcommands not available} -setup {
126    catch {safe::interpDelete a}
127} -body {
128    safe::interpCreate a
129    safe::loadTk a
130    set status broken
131    if {[catch {interp eval a {tk appname}} msg]} {
132	set status ok
133    }
134    list $status $msg
135} -cleanup {
136    safe::interpDelete a
137} -result {ok {appname not accessible in a safe interpreter}}
138test safe-2.4 {Unsafe subcommands not available} -setup {
139    catch {safe::interpDelete a}
140} -body {
141    safe::interpCreate a
142    safe::loadTk a
143    set status broken
144    if {[catch {interp eval a {tk scaling}} msg]} {
145	set status ok
146    }
147    list $status $msg
148} -cleanup {
149    safe::interpDelete a
150} -result {ok {scaling not accessible in a safe interpreter}}
151
152test safe-3.1 {Unsafe commands are available hidden} -setup {
153    catch {safe::interpDelete a}
154} -body {
155    safe::interpCreate a
156    safe::loadTk a
157    set status ok
158    if {[catch {interp invokehidden a toplevel .t} msg]} {
159	set status broken
160    }
161    return $status
162} -cleanup {
163    safe::interpDelete a
164} -result ok
165test safe-3.2 {Unsafe commands are available hidden} -setup {
166    catch {safe::interpDelete a}
167} -body {
168    safe::interpCreate a
169    safe::loadTk a
170    set status ok
171    if {[catch {interp invokehidden a menu .m} msg]} {
172	set status broken
173    }
174    return $status
175} -cleanup {
176    safe::interpDelete a
177} -result ok
178
179test safe-4.1 {testing loadTk} -body {
180    # no error shall occur, the user will eventually see a new toplevel
181    set i [safe::loadTk [safe::interpCreate]]
182    interp eval $i {button .b -text "hello world!"; pack .b}
183    # lets don't update because it might imply that the user has to position
184    # the window (if the wm does not do it automatically) and thus make the
185    # test suite not runable non interactively
186    safe::interpDelete $i
187} -result {}
188test safe-4.2 {testing loadTk -use} -setup {
189    destroy .safeTkFrame
190} -body {
191    set w .safeTkFrame
192    frame $w -container 1;
193    pack $w
194    set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]]
195    interp eval $i {button .b -text "hello world!"; pack .b}
196    safe::interpDelete $i
197    destroy $w
198} -result {}
199
200test safe-5.1 {loading Tk in safe interps without parent's clearance} -body {
201    set i [safe::interpCreate]
202    interp eval $i {load {} Tk}
203} -cleanup {
204    safe::interpDelete $i
205} -returnCodes error -match glob -result {*not allowed}
206test safe-5.2 {multi-level Tk loading with clearance} -setup {
207    set safeParent [safe::interpCreate]
208} -body {
209    # No error shall occur in that test and no window shall remain at the end.
210    set i [safe::interpCreate [list $safeParent x]]
211    safe::loadTk $i
212    interp eval $i {
213	button .b -text Ok -command {destroy .}
214	pack .b
215#	tkwait window . ; # for interactive testing/debugging
216    }
217} -cleanup {
218    catch {safe::interpDelete $i}
219    safe::interpDelete $safeParent
220} -result {}
221
222test safe-6.1 {loadTk -use windowPath} -setup {
223    destroy .safeTkFrame
224} -body {
225    set w .safeTkFrame
226    frame $w -container 1;
227    pack $w
228    set i [safe::loadTk [safe::interpCreate] -use $w]
229    interp eval $i {button .b -text "hello world!"; pack .b}
230    safe::interpDelete $i
231    destroy $w
232} -result {}
233test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup {
234    destroy .safeTkFrame
235} -body {
236    set w .safeTkFrame
237    frame $w -container 1;
238    pack $w
239    set i     [safe::interpCreate]
240    catch {safe::loadTk $i -use $w -display :23.56} msg
241    string range $msg 0 36
242} -cleanup {
243    safe::interpDelete $i
244    destroy $w
245} -result {conflicting -display :23.56 and -use }
246
247test safe-7.1 {canvas printing} -body {
248    set i [safe::loadTk [safe::interpCreate]]
249    interp eval $i {canvas .c; .c postscript}
250} -cleanup {
251    safe::interpDelete $i
252} -returnCodes ok -match glob -result *
253
254# cleanup
255set ::auto_path $saveAutoPath
256unset hidden_cmds
257cleanupTests
258return
259
260# Local Variables:
261# mode: tcl
262# fill-column: 78
263# End:
264