Initial revision

1 files changed, 148 insertions, 0 deletions

diff --git a/library/safetk.tcl b/library/safetk.tcl
new file mode 100644
index 0000000..1cabcd5
--- /dev/null
+++ b/library/safetk.tcl
@@ -0,0 +1,148 @@
+# safetk.tcl --
+#
+# Support procs to use Tk in safe interpreters.
+#
+# SCCS: @(#) safetk.tcl 1.8 97/10/29 14:59:16
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# see safetk.n for documentation
+
+#
+#
+# Note: It is UNSAFE to let any 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
+#
+
+# We use opt (optional arguments parsing)
+package require opt 0.1;
+
+namespace eval ::safe {
+
+    # counter for safe toplevels
+    variable tkSafeId 0;
+
+    #
+    # tkInterpInit : prepare the slave interpreter for tk loading
+    #
+    # returns the slave name (tkInterpInit does)
+    #
+    proc ::safe::tkInterpInit {slave} {
+	global env tk_library
+	if {[info exists env(DISPLAY)]} {
+	    $slave eval [list set env(DISPLAY) $env(DISPLAY)];
+	}
+	# 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
+	::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
+	return $slave;
+    }
+
+
+# tkInterpLoadTk : 
+# Do additional configuration as needed (calling tkInterpInit) 
+# and actually load Tk into the slave.
+# 
+# Either contained in the specified windowId (-use) or
+# creating a decorated toplevel for it.
+
+# empty definition for auto_mkIndex
+proc ::safe::loadTk {} {}
+   
+    ::tcl::OptProc loadTk {
+	{slave -interp "name of the slave interpreter"}
+	{-use  -windowId {} "window Id to use (new toplevel otherwise)"}
+    } {
+	if {![::tcl::OptProcArgGiven "-use"]} {
+	    # create a decorated toplevel
+	    ::tcl::Lassign [tkTopLevel $slave] w use;
+	    # set our delete hook (slave arg is added by interpDelete)
+	    Set [DeleteHookName $slave] [list tkDelete {} $w];
+	}
+	tkInterpInit $slave;
+	::interp eval $slave [list set argv [list "-use" $use]];
+	::interp eval $slave [list set argc 2];
+	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::tkDelete {W window slave} {
+	# we are going to be called for each widget... skip untill it's
+	# top level
+	Log $slave "Called tkDelete $W $window" NOTICE;
+	if {[::interp exists $slave]} {
+	    if {[catch {::safe::interpDelete $slave} msg]} {
+		Log $slave "Deletion error : $msg";
+	    }
+	}
+	if {[winfo exists $window]} {
+	    Log $slave "Destroy toplevel $window" NOTICE;
+	    destroy $window;
+	}
+    }
+
+proc ::safe::tkTopLevel {slave} {
+    variable tkSafeId;
+    incr tkSafeId;
+    set w ".safe$tkSafeId";
+    if {[catch {toplevel $w -class SafeTk} msg]} {
+	return -code error "Unable to create toplevel for\
+		safe slave \"$slave\" ($msg)";
+    }
+    Log $slave "New toplevel $w" NOTICE
+
+    set msg "Untrusted Tcl applet ($slave)"
+    wm title $w $msg;
+
+    # Control frame
+    set wc $w.fc
+    frame $wc -bg red -borderwidth 3 -relief ridge ;
+
+    # We will destroy the interp when the window is destroyed
+    bindtags $wc [concat Safe$wc [bindtags $wc]]
+    bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave];
+
+    label $wc.l -text $msg \
+	    -padx 2 -pady 0 -anchor w;
+
+    # We want the button to be the last visible item
+    # (so be packed first) and at the right and not resizing horizontally
+
+    # frame the button so it does not expand horizontally
+    # but still have the default background instead of red one from the parent
+    frame  $wc.fb -bd 0 ;
+    button $wc.fb.b -text "Delete" \
+	    -bd 1  -padx 2 -pady 0 -highlightthickness 0 \
+	    -command [list ::safe::tkDelete $w $w $slave]
+    pack $wc.fb.b -side right -fill both ;
+    pack $wc.fb -side right -fill both -expand 1;
+    pack $wc.l -side left  -fill both -expand 1;
+    pack $wc -side bottom -fill x ;
+
+    # Container frame
+    frame $w.c -container 1;
+    pack $w.c -fill both -expand 1;
+    
+    # return both the toplevel window name and the id to use for embedding
+    list $w [winfo id $w.c] ;
+}
+
+}