3 # Support procs to use Tk in safe interpreters.
5 # RCS: @(#) $Id: safetk.tcl,v 1.12.2.1 2009/12/10 00:34:12 andreas_kupries Exp $
7 # Copyright (c) 1997 Sun Microsystems, Inc.
9 # See the file "license.terms" for information on usage and redistribution
10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 # see safetk.n for documentation
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.
24 # We use opt (optional arguments parsing)
25 package require opt
0.4.1;
27 namespace eval ::safe {
29 # counter for safe toplevels
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)
38 proc ::safe::tkInterpInit {slave argv
} {
41 # We have to make sure that the tk_library variable is normalized.
42 set tk_library
[file normalize
$tk_library]
44 # Clear Tk's access for that interp (path).
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
57 # Do additional configuration as needed (calling tkInterpInit)
58 # and actually load Tk into the slave.
60 # Either contained in the specified windowId (-use) or
61 # creating a decorated toplevel for it.
63 # empty definition for auto_mkIndex
64 proc ::safe::loadTk {} {}
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)"}
71 set displayGiven
[::tcl::OptProcArgGiven "-display"]
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
)
79 Log
$slave "no winfo screen . nor env(DISPLAY)" WARNING
85 # Get state for access to the cleanupHook.
86 namespace upvar ::safe S
$slave state
88 if {![::tcl::OptProcArgGiven "-use"]} {
89 # create a decorated toplevel
90 ::tcl::Lassign [tkTopLevel
$slave $display] w use
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]
98 # set our delete hook (slave arg is added by interpDelete)
99 # to clean up tkInit(slave)
100 set state
(cleanupHook
) [list disallowTk
]
102 # Let's be nice and also accept tk window names instead of ids
103 if {[string match
".*" $use]} {
105 set use
[winfo id
$windowName]
106 set nDisplay
[winfo screen
$windowName]
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]
115 # Can't have a better one
116 set nDisplay
$display
119 if {$nDisplay ne
$display} {
121 error "conflicting -display $display and -use\
124 set display
$nDisplay
129 # Prepares the slave for tk with those parameters
130 tkInterpInit
$slave [list "-use" $use "-display" $display]
137 proc ::safe::TkInit {interpPath
} {
139 if {[info exists tkInit
($interpPath)]} {
140 set value
$tkInit($interpPath)
141 Log
$interpPath "TkInit called, returning \"$value\"" NOTICE
144 Log
$interpPath "TkInit called for interp with clearance:\
145 preventing Tk init" ERROR
152 # Set tkInit(interpPath) to allow Tk to be initialized in
156 # interpPath slave interpreter handle
157 # argv arguments passed to safe::TkInterpInit
162 proc ::safe::allowTk {interpPath argv
} {
164 set tkInit
($interpPath) $argv
169 # safe::disallowTk --
171 # Unset tkInit(interpPath) to disallow Tk from getting initialized
175 # interpPath slave interpreter handle
180 proc ::safe::disallowTk {interpPath
} {
182 # This can already be deleted by the DeleteHook of the interp
183 if {[info exists tkInit
($interpPath)]} {
184 unset tkInit
($interpPath)
192 # Clean up the window associated with the interp being deleted.
195 # interpPath slave interpreter handle
200 proc ::safe::tkDelete {W window slave
} {
202 # we are going to be called for each widget... skip untill it's
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"
211 if {[winfo exists
$window]} {
212 Log
$slave "Destroy toplevel $window" NOTICE
216 # clean up tkInit(slave)
221 proc ::safe::tkTopLevel {slave display
} {
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)"
229 Log
$slave "New toplevel $w" NOTICE
231 set msg
"Untrusted Tcl applet ($slave)"
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
239 ttk
::frame $wc -relief ridge
-borderwidth 4 -style TWarningFrame
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]
245 ttk
::label $wc.l
-text $msg -anchor w
247 # We want the button to be the last visible item
248 # (so be packed first) and at the right and not resizing horizontally
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
261 frame $w.c
-container 1
262 pack $w.c
-fill both
-expand 1
264 # return both the toplevel window name and the id to use for embedding
265 list $w [winfo id
$w.c
]