# Support procs to use Tk in safe interpreters.
# RCS: @(#) $Id: safetk.tcl,v 1.8 2000/10/31 01:11:51 hobbs Exp $
# 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;
# counter for safe toplevels
# 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
} {
# We have to make sure that the tk_library variable uses a file
# pathname that works better in Tk (of the style returned by
# [file join], ie C:/path/to/tk/lib, not C:\path\to\tk\lib
set tk_library
[file join $tk_library]
# Clear Tk's access for that interp (path).
# 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.
# Might be usefull for masters without Tk really loaded too.
::interp eval $slave [list set tk_library
[::safe::interpAddToAccessPath $slave $tk_library]]
# 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 {} {}
{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"]
# 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
)
Log
$slave "no winfo screen . nor env(DISPLAY)" WARNING
if {![::tcl::OptProcArgGiven "-use"]} {
# create a decorated toplevel
::tcl::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
[DeleteHookName
$slave] [list tkDelete
{} $w]
# set our delete hook (slave arg is added by interpDelete)
# to clean up tkInit(slave)
Set
[DeleteHookName
$slave] [list disallowTk
]
# Let's be nice and also accept tk window names instead of ids
if {[string match
".*" $use]} {
set use
[winfo id
$windowName]
set nDisplay
[winfo screen
$windowName]
# 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]
# Can't have a better one
if {[string compare
$nDisplay $display]} {
error "conflicting -display $display and -use\
# Prepares the slave for tk with those parameters
tkInterpInit
$slave [list "-use" $use "-display" $display]
proc ::safe::TkInit {interpPath
} {
if {[info exists tkInit
($interpPath)]} {
set value
$tkInit($interpPath)
Log
$interpPath "TkInit called, returning \"$value\"" NOTICE
Log
$interpPath "TkInit called for interp with clearance:\
preventing Tk init" ERROR
# Set tkInit(interpPath) to allow Tk to be initialized in
# interpPath slave interpreter handle
# argv arguments passed to safe::TkInterpInit
proc ::safe::allowTk {interpPath argv
} {
set tkInit
($interpPath) $argv
# Unset tkInit(interpPath) to disallow Tk from getting initialized
# interpPath slave interpreter handle
proc ::safe::disallowTk {interpPath
} {
# This can already be deleted by the DeleteHook of the interp
if {[info exists tkInit
($interpPath)]} {
unset tkInit
($interpPath)
# Clean up the window associated with the interp being deleted.
# interpPath slave interpreter handle
proc ::safe::tkDelete {W window slave
} {
# we are going to be called for each widget... skip untill it's
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
proc ::safe::tkTopLevel {slave display
} {
if {[catch {toplevel $w -screen $display -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)"
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
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
pack $w.c
-fill both
-expand 1
# return both the toplevel window name and the id to use for embedding