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