Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | # safetk.tcl -- |
2 | # | |
3 | # Support procs to use Tk in safe interpreters. | |
4 | # | |
5 | # RCS: @(#) $Id: safetk.tcl,v 1.8 2000/10/31 01:11:51 hobbs Exp $ | |
6 | # | |
7 | # Copyright (c) 1997 Sun Microsystems, Inc. | |
8 | # | |
9 | # See the file "license.terms" for information on usage and redistribution | |
10 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
11 | ||
12 | # see safetk.n for documentation | |
13 | ||
14 | # | |
15 | # | |
16 | # Note: It is now ok to let untrusted code being executed | |
17 | # between the creation of the interp and the actual loading | |
18 | # of Tk in that interp because the C side Tk_Init will | |
19 | # now look up the master interp and ask its safe::TkInit | |
20 | # for the actual parameters to use for it's initialization (if allowed), | |
21 | # not relying on the slave state. | |
22 | # | |
23 | ||
24 | # We use opt (optional arguments parsing) | |
25 | package require opt 0.4.1; | |
26 | ||
27 | namespace eval ::safe { | |
28 | ||
29 | # counter for safe toplevels | |
30 | variable tkSafeId 0; | |
31 | ||
32 | # | |
33 | # tkInterpInit : prepare the slave interpreter for tk loading | |
34 | # most of the real job is done by loadTk | |
35 | # returns the slave name (tkInterpInit does) | |
36 | # | |
37 | proc ::safe::tkInterpInit {slave argv} { | |
38 | global env tk_library | |
39 | ||
40 | # We have to make sure that the tk_library variable uses a file | |
41 | # pathname that works better in Tk (of the style returned by | |
42 | # [file join], ie C:/path/to/tk/lib, not C:\path\to\tk\lib | |
43 | set tk_library [file join $tk_library] | |
44 | ||
45 | # Clear Tk's access for that interp (path). | |
46 | allowTk $slave $argv | |
47 | ||
48 | # there seems to be an obscure case where the tk_library | |
49 | # variable value is changed to point to a sym link destination | |
50 | # dir instead of the sym link itself, and thus where the $tk_library | |
51 | # would then not be anymore one of the auto_path dir, so we use | |
52 | # the addToAccessPath which adds if it's not already in instead | |
53 | # of the more conventional findInAccessPath. | |
54 | # Might be usefull for masters without Tk really loaded too. | |
55 | ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]] | |
56 | return $slave | |
57 | } | |
58 | ||
59 | ||
60 | # tkInterpLoadTk : | |
61 | # Do additional configuration as needed (calling tkInterpInit) | |
62 | # and actually load Tk into the slave. | |
63 | # | |
64 | # Either contained in the specified windowId (-use) or | |
65 | # creating a decorated toplevel for it. | |
66 | ||
67 | # empty definition for auto_mkIndex | |
68 | proc ::safe::loadTk {} {} | |
69 | ||
70 | ::tcl::OptProc loadTk { | |
71 | {slave -interp "name of the slave interpreter"} | |
72 | {-use -windowId {} "window Id to use (new toplevel otherwise)"} | |
73 | {-display -displayName {} "display name to use (current one otherwise)"} | |
74 | } { | |
75 | set displayGiven [::tcl::OptProcArgGiven "-display"] | |
76 | if {!$displayGiven} { | |
77 | ||
78 | # Try to get the current display from "." | |
79 | # (which might not exist if the master is tk-less) | |
80 | ||
81 | if {[catch {set display [winfo screen .]}]} { | |
82 | if {[info exists ::env(DISPLAY)]} { | |
83 | set display $::env(DISPLAY) | |
84 | } else { | |
85 | Log $slave "no winfo screen . nor env(DISPLAY)" WARNING | |
86 | set display ":0.0" | |
87 | } | |
88 | } | |
89 | } | |
90 | if {![::tcl::OptProcArgGiven "-use"]} { | |
91 | ||
92 | # create a decorated toplevel | |
93 | ||
94 | ::tcl::Lassign [tkTopLevel $slave $display] w use | |
95 | ||
96 | # set our delete hook (slave arg is added by interpDelete) | |
97 | # to clean up both window related code and tkInit(slave) | |
98 | Set [DeleteHookName $slave] [list tkDelete {} $w] | |
99 | ||
100 | } else { | |
101 | ||
102 | # set our delete hook (slave arg is added by interpDelete) | |
103 | # to clean up tkInit(slave) | |
104 | ||
105 | Set [DeleteHookName $slave] [list disallowTk] | |
106 | ||
107 | # Let's be nice and also accept tk window names instead of ids | |
108 | ||
109 | if {[string match ".*" $use]} { | |
110 | set windowName $use | |
111 | set use [winfo id $windowName] | |
112 | set nDisplay [winfo screen $windowName] | |
113 | } else { | |
114 | ||
115 | # Check for a better -display value | |
116 | # (works only for multi screens on single host, but not | |
117 | # cross hosts, for that a tk window name would be better | |
118 | # but embeding is also usefull for non tk names) | |
119 | ||
120 | if {![catch {winfo pathname $use} name]} { | |
121 | set nDisplay [winfo screen $name] | |
122 | } else { | |
123 | ||
124 | # Can't have a better one | |
125 | ||
126 | set nDisplay $display | |
127 | } | |
128 | } | |
129 | if {[string compare $nDisplay $display]} { | |
130 | if {$displayGiven} { | |
131 | error "conflicting -display $display and -use\ | |
132 | $use -> $nDisplay" | |
133 | } else { | |
134 | set display $nDisplay | |
135 | } | |
136 | } | |
137 | } | |
138 | ||
139 | # Prepares the slave for tk with those parameters | |
140 | ||
141 | tkInterpInit $slave [list "-use" $use "-display" $display] | |
142 | ||
143 | load {} Tk $slave | |
144 | ||
145 | return $slave | |
146 | } | |
147 | ||
148 | proc ::safe::TkInit {interpPath} { | |
149 | variable tkInit | |
150 | if {[info exists tkInit($interpPath)]} { | |
151 | set value $tkInit($interpPath) | |
152 | Log $interpPath "TkInit called, returning \"$value\"" NOTICE | |
153 | return $value | |
154 | } else { | |
155 | Log $interpPath "TkInit called for interp with clearance:\ | |
156 | preventing Tk init" ERROR | |
157 | error "not allowed" | |
158 | } | |
159 | } | |
160 | ||
161 | # safe::allowTk -- | |
162 | # | |
163 | # Set tkInit(interpPath) to allow Tk to be initialized in | |
164 | # safe::TkInit. | |
165 | # | |
166 | # Arguments: | |
167 | # interpPath slave interpreter handle | |
168 | # argv arguments passed to safe::TkInterpInit | |
169 | # | |
170 | # Results: | |
171 | # none. | |
172 | ||
173 | proc ::safe::allowTk {interpPath argv} { | |
174 | variable tkInit | |
175 | set tkInit($interpPath) $argv | |
176 | return | |
177 | } | |
178 | ||
179 | ||
180 | # safe::disallowTk -- | |
181 | # | |
182 | # Unset tkInit(interpPath) to disallow Tk from getting initialized | |
183 | # in safe::TkInit. | |
184 | # | |
185 | # Arguments: | |
186 | # interpPath slave interpreter handle | |
187 | # | |
188 | # Results: | |
189 | # none. | |
190 | ||
191 | proc ::safe::disallowTk {interpPath} { | |
192 | variable tkInit | |
193 | # This can already be deleted by the DeleteHook of the interp | |
194 | if {[info exists tkInit($interpPath)]} { | |
195 | unset tkInit($interpPath) | |
196 | } | |
197 | return | |
198 | } | |
199 | ||
200 | ||
201 | # safe::tkDelete -- | |
202 | # | |
203 | # Clean up the window associated with the interp being deleted. | |
204 | # | |
205 | # Arguments: | |
206 | # interpPath slave interpreter handle | |
207 | # | |
208 | # Results: | |
209 | # none. | |
210 | ||
211 | proc ::safe::tkDelete {W window slave} { | |
212 | ||
213 | # we are going to be called for each widget... skip untill it's | |
214 | # top level | |
215 | ||
216 | Log $slave "Called tkDelete $W $window" NOTICE | |
217 | if {[::interp exists $slave]} { | |
218 | if {[catch {::safe::interpDelete $slave} msg]} { | |
219 | Log $slave "Deletion error : $msg" | |
220 | } | |
221 | } | |
222 | if {[winfo exists $window]} { | |
223 | Log $slave "Destroy toplevel $window" NOTICE | |
224 | destroy $window | |
225 | } | |
226 | ||
227 | # clean up tkInit(slave) | |
228 | disallowTk $slave | |
229 | return | |
230 | } | |
231 | ||
232 | proc ::safe::tkTopLevel {slave display} { | |
233 | variable tkSafeId | |
234 | incr tkSafeId | |
235 | set w ".safe$tkSafeId" | |
236 | if {[catch {toplevel $w -screen $display -class SafeTk} msg]} { | |
237 | return -code error "Unable to create toplevel for\ | |
238 | safe slave \"$slave\" ($msg)" | |
239 | } | |
240 | Log $slave "New toplevel $w" NOTICE | |
241 | ||
242 | set msg "Untrusted Tcl applet ($slave)" | |
243 | wm title $w $msg | |
244 | ||
245 | # Control frame | |
246 | set wc $w.fc | |
247 | frame $wc -bg red -borderwidth 3 -relief ridge | |
248 | ||
249 | # We will destroy the interp when the window is destroyed | |
250 | bindtags $wc [concat Safe$wc [bindtags $wc]] | |
251 | bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave] | |
252 | ||
253 | label $wc.l -text $msg -padx 2 -pady 0 -anchor w | |
254 | ||
255 | # We want the button to be the last visible item | |
256 | # (so be packed first) and at the right and not resizing horizontally | |
257 | ||
258 | # frame the button so it does not expand horizontally | |
259 | # but still have the default background instead of red one from the parent | |
260 | frame $wc.fb -bd 0 | |
261 | button $wc.fb.b -text "Delete" \ | |
262 | -bd 1 -padx 2 -pady 0 -highlightthickness 0 \ | |
263 | -command [list ::safe::tkDelete $w $w $slave] | |
264 | pack $wc.fb.b -side right -fill both | |
265 | pack $wc.fb -side right -fill both -expand 1 | |
266 | pack $wc.l -side left -fill both -expand 1 | |
267 | pack $wc -side bottom -fill x | |
268 | ||
269 | # Container frame | |
270 | frame $w.c -container 1 | |
271 | pack $w.c -fill both -expand 1 | |
272 | ||
273 | # return both the toplevel window name and the id to use for embedding | |
274 | list $w [winfo id $w.c] | |
275 | } | |
276 | ||
277 | } |