summaryrefslogtreecommitdiffstats
path: root/library/safetk.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/safetk.tcl')
-rw-r--r--library/safetk.tcl104
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)";
}