safetk.tcl
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) 23 package require opt 0.4.1; 24 25 namespace 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 # 36 proc ::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 62 proc ::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 133 proc ::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 158 proc ::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 176 proc ::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 196 proc ::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 217 proc ::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 }