blob: 1cabcd5490032cfcebf2eba8edde2ceb14a75df9 (
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
|
# 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] ;
}
}
|
