diff options
Diffstat (limited to 'library/safetk.tcl')
| -rw-r--r-- | library/safetk.tcl | 104 |
1 files changed, 80 insertions, 24 deletions
diff --git a/library/safetk.tcl b/library/safetk.tcl index 1cabcd5..40482ec 100644 --- a/library/safetk.tcl +++ b/library/safetk.tcl @@ -13,16 +13,12 @@ # # -# Note: It is UNSAFE to let any untrusted code being executed +# Note: It is now ok to let untrusted code being executed # between the creation of the interp and the actual loading -# of Tk in that interp. -# You should "loadTk $slave" right after safe::tkInterpCreate -# Otherwise, if you are using an application with Tk -# and don't want safe slaves to have access to Tk, potentially -# in a malevolent way, you should use -# ::safe::interpCreate -nostatics -accesspath {directories...} -# where the directory list does NOT contain any Tk dynamically -# loadable library +# of Tk in that interp because the C side Tk_Init will +# now look up the master interp and ask its safe::TkInit +# for the actual parameters to use for it's initialization (if allowed), +# not relying on the slave state. # # We use opt (optional arguments parsing) @@ -35,20 +31,22 @@ namespace eval ::safe { # # tkInterpInit : prepare the slave interpreter for tk loading - # + # most of the real job is done by loadTk # returns the slave name (tkInterpInit does) # - proc ::safe::tkInterpInit {slave} { + proc ::safe::tkInterpInit {slave argv} { global env tk_library - if {[info exists env(DISPLAY)]} { - $slave eval [list set env(DISPLAY) $env(DISPLAY)]; - } + + # Clear Tk's access for that interp (path). + allowTk $slave $argv + # there seems to be an obscure case where the tk_library # variable value is changed to point to a sym link destination # dir instead of the sym link itself, and thus where the $tk_library # would then not be anymore one of the auto_path dir, so we use # the addToAccessPath which adds if it's not already in instead - # of the more conventional findInAccessPath + # of the more conventional findInAccessPath. + # Might be usefull for masters without Tk really loaded too. ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]] return $slave; } @@ -67,23 +65,81 @@ proc ::safe::loadTk {} {} ::tcl::OptProc loadTk { {slave -interp "name of the slave interpreter"} {-use -windowId {} "window Id to use (new toplevel otherwise)"} + {-display -displayName {} "display name to use (current one otherwise)"} } { + set displayGiven [::tcl::OptProcArgGiven "-display"] + if {!$displayGiven} { + # Try to get the current display from "." + # (which might not exist if the master is tk-less) + if {[catch {set display [winfo screen .]}]} { + if {[info exists ::env(DISPLAY)]} { + set display $::env(DISPLAY) + } else { + Log $slave "no winfo screen . nor env(DISPLAY)" WARNING + set display ":0.0" + } + } + } if {![::tcl::OptProcArgGiven "-use"]} { # create a decorated toplevel - ::tcl::Lassign [tkTopLevel $slave] w use; + ::tcl::Lassign [tkTopLevel $slave $display] w use; # set our delete hook (slave arg is added by interpDelete) Set [DeleteHookName $slave] [list tkDelete {} $w]; + } else { + # Let's be nice and also accept tk window names instead of ids + if {[string match ".*" $use]} { + set windowName $use + set use [winfo id $windowName] + set nDisplay [winfo screen $windowName] + } else { + # Check for a better -display value + # (works only for multi screens on single host, but not + # cross hosts, for that a tk window name would be better + # but embeding is also usefull for non tk names) + if {![catch {winfo pathname $use} name]} { + set nDisplay [winfo screen $name] + } else { + # Can't have a better one + set nDisplay $display + } + } + if {[string compare $nDisplay $display]} { + if {$displayGiven} { + error "conflicting -display $display and -use\ + $use -> $nDisplay" + } else { + set display $nDisplay + } + } } - tkInterpInit $slave; - ::interp eval $slave [list set argv [list "-use" $use]]; - ::interp eval $slave [list set argc 2]; + + # Prepares the slave for tk with those parameters + + tkInterpInit $slave [list "-use" $use "-display" $display] + load {} Tk $slave - # Remove env(DISPLAY) if it's in there (if it has been set by - # tkInterpInit) - ::interp eval $slave {catch {unset env(DISPLAY)}} + return $slave } +proc ::safe::TkInit {interpPath} { + variable tkInit + if {[info exists tkInit($interpPath)]} { + set value $tkInit($interpPath) + Log $interpPath "TkInit called, returning \"$value\"" NOTICE + return $value + } else { + Log $interpPath "TkInit called for interp with clearance:\ + preventing Tk init" ERROR + error "not allowed" + } +} + +proc ::safe::allowTk {interpPath argv} { + variable tkInit + set tkInit($interpPath) $argv +} + proc ::safe::tkDelete {W window slave} { # we are going to be called for each widget... skip untill it's # top level @@ -99,11 +155,11 @@ proc ::safe::loadTk {} {} } } -proc ::safe::tkTopLevel {slave} { +proc ::safe::tkTopLevel {slave display} { variable tkSafeId; incr tkSafeId; set w ".safe$tkSafeId"; - if {[catch {toplevel $w -class SafeTk} msg]} { + if {[catch {toplevel $w -screen $display -class SafeTk} msg]} { return -code error "Unable to create toplevel for\ safe slave \"$slave\" ($msg)"; } |