blob: 78aeb8608d163b91c8f3d03fb83b72c05357f3bf (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
# safetk.tcl --
#
# Support procs to use Tk in safe interpreters.
#
# RCS: @(#) $Id: safetk.tcl,v 1.3 1998/09/14 18:23:24 stanton 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.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
# 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.
# Might be usefull for masters without Tk really loaded too.
::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)"}
{-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 $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
}
}
}
# 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
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
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 display} {
variable tkSafeId;
incr tkSafeId;
set w ".safe$tkSafeId";
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)"
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] ;
}
}
|
