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