OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tk/] [library/] [safetk.tcl] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
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
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.