summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl')
-rw-r--r--Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl262
1 files changed, 262 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl b/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl
new file mode 100644
index 00000000000..9f8e25d094c
--- /dev/null
+++ b/Master/tlpkg/tltcl/lib/tk8.6/safetk.tcl
@@ -0,0 +1,262 @@
+# safetk.tcl --
+#
+# Support procs to use Tk in safe interpreters.
+#
+# 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 now ok to let untrusted code being executed
+# between the creation of the interp and the actual loading
+# 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)
+package require opt 0.4.1;
+
+namespace eval ::safe {
+
+ # counter for safe toplevels
+ variable tkSafeId 0
+}
+
+#
+# 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 argv} {
+ global env tk_library
+
+ # We have to make sure that the tk_library variable is normalized.
+ set tk_library [file normalize $tk_library]
+
+ # Clear Tk's access for that interp (path).
+ allowTk $slave $argv
+
+ # Ensure tk_library and subdirs (eg, ttk) are on the access path
+ ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
+ foreach subdir [::safe::AddSubDirs [list $tk_library]] {
+ ::safe::interpAddToAccessPath $slave $subdir
+ }
+ 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 ::safe::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"
+ }
+ }
+ }
+
+ # Get state for access to the cleanupHook.
+ namespace upvar ::safe S$slave state
+
+ if {![::tcl::OptProcArgGiven "-use"]} {
+ # create a decorated toplevel
+ lassign [tkTopLevel $slave $display] w use
+
+ # set our delete hook (slave arg is added by interpDelete)
+ # to clean up both window related code and tkInit(slave)
+ set state(cleanupHook) [list tkDelete {} $w]
+ } else {
+ # set our delete hook (slave arg is added by interpDelete)
+ # to clean up tkInit(slave)
+ set state(cleanupHook) [list disallowTk]
+
+ # 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 {$nDisplay ne $display} {
+ if {$displayGiven} {
+ return -code error -errorcode {TK DISPLAY SAFE} \
+ "conflicting -display $display and -use $use -> $nDisplay"
+ } else {
+ set display $nDisplay
+ }
+ }
+ }
+
+ # Prepares the slave for tk with those parameters
+ tkInterpInit $slave [list "-use" $use "-display" $display]
+
+ load {} Tk $slave
+
+ 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
+ return -code error -errorcode {TK SAFE PERMISSION} "not allowed"
+ }
+}
+
+# safe::allowTk --
+#
+# Set tkInit(interpPath) to allow Tk to be initialized in
+# safe::TkInit.
+#
+# Arguments:
+# interpPath slave interpreter handle
+# argv arguments passed to safe::TkInterpInit
+#
+# Results:
+# none.
+
+proc ::safe::allowTk {interpPath argv} {
+ variable tkInit
+ set tkInit($interpPath) $argv
+ return
+}
+
+
+# safe::disallowTk --
+#
+# Unset tkInit(interpPath) to disallow Tk from getting initialized
+# in safe::TkInit.
+#
+# Arguments:
+# interpPath slave interpreter handle
+#
+# Results:
+# none.
+
+proc ::safe::disallowTk {interpPath} {
+ variable tkInit
+ # This can already be deleted by the DeleteHook of the interp
+ if {[info exists tkInit($interpPath)]} {
+ unset tkInit($interpPath)
+ }
+ return
+}
+
+
+# safe::tkDelete --
+#
+# Clean up the window associated with the interp being deleted.
+#
+# Arguments:
+# interpPath slave interpreter handle
+#
+# Results:
+# none.
+
+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
+ }
+
+ # clean up tkInit(slave)
+ disallowTk $slave
+ return
+}
+
+proc ::safe::tkTopLevel {slave display} {
+ variable tkSafeId
+ incr tkSafeId
+ set w ".safe$tkSafeId"
+ if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
+ return -code error -errorcode {TK TOPLEVEL SAFE} \
+ "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 (we must create a style for it)
+ ttk::style layout TWarningFrame {WarningFrame.border -sticky nswe}
+ ttk::style configure TWarningFrame -background red
+
+ set wc $w.fc
+ ttk::frame $wc -relief ridge -borderwidth 4 -style TWarningFrame
+
+ # 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]
+
+ ttk::label $wc.l -text $msg -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
+ ttk::frame $wc.fb -borderwidth 0
+ ttk::button $wc.fb.b -text "Delete" \
+ -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 -ipady 2
+ 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]
+}