1 |
578 |
markom |
# safetk.tcl --
|
2 |
|
|
#
|
3 |
|
|
# Support procs to use Tk in safe interpreters.
|
4 |
|
|
#
|
5 |
|
|
# SCCS: @(#) safetk.tcl 1.8 97/10/29 14:59:16
|
6 |
|
|
#
|
7 |
|
|
# Copyright (c) 1997 Sun Microsystems, Inc.
|
8 |
|
|
#
|
9 |
|
|
# See the file "license.terms" for information on usage and redistribution
|
10 |
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
11 |
|
|
|
12 |
|
|
# see safetk.n for documentation
|
13 |
|
|
|
14 |
|
|
#
|
15 |
|
|
#
|
16 |
|
|
# Note: It is now ok to let untrusted code being executed
|
17 |
|
|
# between the creation of the interp and the actual loading
|
18 |
|
|
# of Tk in that interp because the C side Tk_Init will
|
19 |
|
|
# now look up the master interp and ask its safe::TkInit
|
20 |
|
|
# for the actual parameters to use for it's initialization (if allowed),
|
21 |
|
|
# not relying on the slave state.
|
22 |
|
|
#
|
23 |
|
|
|
24 |
|
|
# We use opt (optional arguments parsing)
|
25 |
|
|
package require opt 0.1;
|
26 |
|
|
|
27 |
|
|
namespace eval ::safe {
|
28 |
|
|
|
29 |
|
|
# counter for safe toplevels
|
30 |
|
|
variable tkSafeId 0;
|
31 |
|
|
|
32 |
|
|
#
|
33 |
|
|
# tkInterpInit : prepare the slave interpreter for tk loading
|
34 |
|
|
# most of the real job is done by loadTk
|
35 |
|
|
# returns the slave name (tkInterpInit does)
|
36 |
|
|
#
|
37 |
|
|
proc ::safe::tkInterpInit {slave argv} {
|
38 |
|
|
global env tk_library
|
39 |
|
|
|
40 |
|
|
# Clear Tk's access for that interp (path).
|
41 |
|
|
allowTk $slave $argv
|
42 |
|
|
|
43 |
|
|
# there seems to be an obscure case where the tk_library
|
44 |
|
|
# variable value is changed to point to a sym link destination
|
45 |
|
|
# dir instead of the sym link itself, and thus where the $tk_library
|
46 |
|
|
# would then not be anymore one of the auto_path dir, so we use
|
47 |
|
|
# the addToAccessPath which adds if it's not already in instead
|
48 |
|
|
# of the more conventional findInAccessPath.
|
49 |
|
|
# Might be usefull for masters without Tk really loaded too.
|
50 |
|
|
::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
|
51 |
|
|
return $slave;
|
52 |
|
|
}
|
53 |
|
|
|
54 |
|
|
|
55 |
|
|
# tkInterpLoadTk :
|
56 |
|
|
# Do additional configuration as needed (calling tkInterpInit)
|
57 |
|
|
# and actually load Tk into the slave.
|
58 |
|
|
#
|
59 |
|
|
# Either contained in the specified windowId (-use) or
|
60 |
|
|
# creating a decorated toplevel for it.
|
61 |
|
|
|
62 |
|
|
# empty definition for auto_mkIndex
|
63 |
|
|
proc ::safe::loadTk {} {}
|
64 |
|
|
|
65 |
|
|
::tcl::OptProc loadTk {
|
66 |
|
|
{slave -interp "name of the slave interpreter"}
|
67 |
|
|
{-use -windowId {} "window Id to use (new toplevel otherwise)"}
|
68 |
|
|
{-display -displayName {} "display name to use (current one otherwise)"}
|
69 |
|
|
} {
|
70 |
|
|
set displayGiven [::tcl::OptProcArgGiven "-display"]
|
71 |
|
|
if {!$displayGiven} {
|
72 |
|
|
# Try to get the current display from "."
|
73 |
|
|
# (which might not exist if the master is tk-less)
|
74 |
|
|
if {[catch {set display [winfo screen .]}]} {
|
75 |
|
|
if {[info exists ::env(DISPLAY)]} {
|
76 |
|
|
set display $::env(DISPLAY)
|
77 |
|
|
} else {
|
78 |
|
|
Log $slave "no winfo screen . nor env(DISPLAY)" WARNING
|
79 |
|
|
set display ":0.0"
|
80 |
|
|
}
|
81 |
|
|
}
|
82 |
|
|
}
|
83 |
|
|
if {![::tcl::OptProcArgGiven "-use"]} {
|
84 |
|
|
# create a decorated toplevel
|
85 |
|
|
::tcl::Lassign [tkTopLevel $slave $display] w use;
|
86 |
|
|
# set our delete hook (slave arg is added by interpDelete)
|
87 |
|
|
Set [DeleteHookName $slave] [list tkDelete {} $w];
|
88 |
|
|
} else {
|
89 |
|
|
# Let's be nice and also accept tk window names instead of ids
|
90 |
|
|
if {[string match ".*" $use]} {
|
91 |
|
|
set windowName $use
|
92 |
|
|
set use [winfo id $windowName]
|
93 |
|
|
set nDisplay [winfo screen $windowName]
|
94 |
|
|
} else {
|
95 |
|
|
# Check for a better -display value
|
96 |
|
|
# (works only for multi screens on single host, but not
|
97 |
|
|
# cross hosts, for that a tk window name would be better
|
98 |
|
|
# but embeding is also usefull for non tk names)
|
99 |
|
|
if {![catch {winfo pathname $use} name]} {
|
100 |
|
|
set nDisplay [winfo screen $name]
|
101 |
|
|
} else {
|
102 |
|
|
# Can't have a better one
|
103 |
|
|
set nDisplay $display
|
104 |
|
|
}
|
105 |
|
|
}
|
106 |
|
|
if {[string compare $nDisplay $display]} {
|
107 |
|
|
if {$displayGiven} {
|
108 |
|
|
error "conflicting -display $display and -use\
|
109 |
|
|
$use -> $nDisplay"
|
110 |
|
|
} else {
|
111 |
|
|
set display $nDisplay
|
112 |
|
|
}
|
113 |
|
|
}
|
114 |
|
|
}
|
115 |
|
|
|
116 |
|
|
# Prepares the slave for tk with those parameters
|
117 |
|
|
|
118 |
|
|
tkInterpInit $slave [list "-use" $use "-display" $display]
|
119 |
|
|
|
120 |
|
|
load {} Tk $slave
|
121 |
|
|
|
122 |
|
|
return $slave
|
123 |
|
|
}
|
124 |
|
|
|
125 |
|
|
proc ::safe::TkInit {interpPath} {
|
126 |
|
|
variable tkInit
|
127 |
|
|
if {[info exists tkInit($interpPath)]} {
|
128 |
|
|
set value $tkInit($interpPath)
|
129 |
|
|
Log $interpPath "TkInit called, returning \"$value\"" NOTICE
|
130 |
|
|
return $value
|
131 |
|
|
} else {
|
132 |
|
|
Log $interpPath "TkInit called for interp with clearance:\
|
133 |
|
|
preventing Tk init" ERROR
|
134 |
|
|
error "not allowed"
|
135 |
|
|
}
|
136 |
|
|
}
|
137 |
|
|
|
138 |
|
|
proc ::safe::allowTk {interpPath argv} {
|
139 |
|
|
variable tkInit
|
140 |
|
|
set tkInit($interpPath) $argv
|
141 |
|
|
}
|
142 |
|
|
|
143 |
|
|
proc ::safe::tkDelete {W window slave} {
|
144 |
|
|
# we are going to be called for each widget... skip untill it's
|
145 |
|
|
# top level
|
146 |
|
|
Log $slave "Called tkDelete $W $window" NOTICE;
|
147 |
|
|
if {[::interp exists $slave]} {
|
148 |
|
|
if {[catch {::safe::interpDelete $slave} msg]} {
|
149 |
|
|
Log $slave "Deletion error : $msg";
|
150 |
|
|
}
|
151 |
|
|
}
|
152 |
|
|
if {[winfo exists $window]} {
|
153 |
|
|
Log $slave "Destroy toplevel $window" NOTICE;
|
154 |
|
|
destroy $window;
|
155 |
|
|
}
|
156 |
|
|
}
|
157 |
|
|
|
158 |
|
|
proc ::safe::tkTopLevel {slave display} {
|
159 |
|
|
variable tkSafeId;
|
160 |
|
|
incr tkSafeId;
|
161 |
|
|
set w ".safe$tkSafeId";
|
162 |
|
|
if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
|
163 |
|
|
return -code error "Unable to create toplevel for\
|
164 |
|
|
safe slave \"$slave\" ($msg)";
|
165 |
|
|
}
|
166 |
|
|
Log $slave "New toplevel $w" NOTICE
|
167 |
|
|
|
168 |
|
|
set msg "Untrusted Tcl applet ($slave)"
|
169 |
|
|
wm title $w $msg;
|
170 |
|
|
|
171 |
|
|
# Control frame
|
172 |
|
|
set wc $w.fc
|
173 |
|
|
frame $wc -bg red -borderwidth 3 -relief ridge ;
|
174 |
|
|
|
175 |
|
|
# We will destroy the interp when the window is destroyed
|
176 |
|
|
bindtags $wc [concat Safe$wc [bindtags $wc]]
|
177 |
|
|
bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave];
|
178 |
|
|
|
179 |
|
|
label $wc.l -text $msg \
|
180 |
|
|
-padx 2 -pady 0 -anchor w;
|
181 |
|
|
|
182 |
|
|
# We want the button to be the last visible item
|
183 |
|
|
# (so be packed first) and at the right and not resizing horizontally
|
184 |
|
|
|
185 |
|
|
# frame the button so it does not expand horizontally
|
186 |
|
|
# but still have the default background instead of red one from the parent
|
187 |
|
|
frame $wc.fb -bd 0 ;
|
188 |
|
|
button $wc.fb.b -text "Delete" \
|
189 |
|
|
-bd 1 -padx 2 -pady 0 -highlightthickness 0 \
|
190 |
|
|
-command [list ::safe::tkDelete $w $w $slave]
|
191 |
|
|
pack $wc.fb.b -side right -fill both ;
|
192 |
|
|
pack $wc.fb -side right -fill both -expand 1;
|
193 |
|
|
pack $wc.l -side left -fill both -expand 1;
|
194 |
|
|
pack $wc -side bottom -fill x ;
|
195 |
|
|
|
196 |
|
|
# Container frame
|
197 |
|
|
frame $w.c -container 1;
|
198 |
|
|
pack $w.c -fill both -expand 1;
|
199 |
|
|
|
200 |
|
|
# return both the toplevel window name and the id to use for embedding
|
201 |
|
|
list $w [winfo id $w.c] ;
|
202 |
|
|
}
|
203 |
|
|
|
204 |
|
|
}
|