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