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