mingw/lib/tk8.4/safetk.tcl

   1 # safetk.tcl --
   2 #
   3 # Support procs to use Tk in safe interpreters.
   4 #
   5 # RCS: @(#) $Id: safetk.tcl,v 1.8.8.1 2006/01/25 18:21:41 dgp Exp $
   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.4.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         # We have to make sure that the tk_library variable uses a file
  41         # pathname that works better in Tk (of the style returned by
  42         # [file join], ie C:/path/to/tk/lib, not C:\path\to\tk\lib
  43         set tk_library [file join $tk_library]
  44
  45         # Clear Tk's access for that interp (path).
  46         allowTk $slave $argv
  47
  48         # there seems to be an obscure case where the tk_library
  49         # variable value is changed to point to a sym link destination
  50         # dir instead of the sym link itself, and thus where the $tk_library
  51         # would then not be anymore one of the auto_path dir, so we use
  52         # the addToAccessPath which adds if it's not already in instead
  53         # of the more conventional findInAccessPath.
  54         # Might be usefull for masters without Tk really loaded too.
  55         ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
  56         return $slave
  57     }
  58
  59
  60 # tkInterpLoadTk :
  61 # Do additional configuration as needed (calling tkInterpInit)
  62 # and actually load Tk into the slave.
  63 #
  64 # Either contained in the specified windowId (-use) or
  65 # creating a decorated toplevel for it.
  66
  67 # empty definition for auto_mkIndex
  68 proc ::safe::loadTk {} {}
  69
  70 ::tcl::OptProc loadTk {
  71     {slave -interp "name of the slave interpreter"}
  72     {-use  -windowId {} "window Id to use (new toplevel otherwise)"}
  73     {-display -displayName {} "display name to use (current one otherwise)"}
  74 } {
  75     set displayGiven [::tcl::OptProcArgGiven "-display"]
  76     if {!$displayGiven} {
  77
  78         # Try to get the current display from "."
  79         # (which might not exist if the master is tk-less)
  80
  81         if {[catch {set display [winfo screen .]}]} {
  82             if {[info exists ::env(DISPLAY)]} {
  83                 set display $::env(DISPLAY)
  84             } else {
  85                 Log $slave "no winfo screen . nor env(DISPLAY)" WARNING
  86                 set display ":0.0"
  87             }
  88         }
  89     }
  90     if {![::tcl::OptProcArgGiven "-use"]} {
  91
  92         # create a decorated toplevel
  93
  94         ::tcl::Lassign [tkTopLevel $slave $display] w use
  95
  96         # set our delete hook (slave arg is added by interpDelete)
  97         # to clean up both window related code and tkInit(slave)
  98         Set [DeleteHookName $slave] [list tkDelete {} $w]
  99
 100     } else {
 101
 102         # set our delete hook (slave arg is added by interpDelete)
 103         # to clean up tkInit(slave)
 104
 105         Set [DeleteHookName $slave] [list disallowTk]
 106
 107         # Let's be nice and also accept tk window names instead of ids
 108
 109         if {[string match ".*" $use]} {
 110             set windowName $use
 111             set use [winfo id $windowName]
 112             set nDisplay [winfo screen $windowName]
 113         } else {
 114
 115             # Check for a better -display value
 116             # (works only for multi screens on single host, but not
 117             #  cross hosts, for that a tk window name would be better
 118             #  but embeding is also usefull for non tk names)
 119
 120             if {![catch {winfo pathname $use} name]} {
 121                 set nDisplay [winfo screen $name]
 122             } else {
 123
 124                 # Can't have a better one
 125
 126                 set nDisplay $display
 127             }
 128         }
 129         if {$nDisplay ne $display} {
 130             if {$displayGiven} {
 131                 error "conflicting -display $display and -use\
 132                         $use -> $nDisplay"
 133             } else {
 134                 set display $nDisplay
 135             }
 136         }
 137     }
 138
 139     # Prepares the slave for tk with those parameters
 140
 141     tkInterpInit $slave [list "-use" $use "-display" $display]
 142
 143     load {} Tk $slave
 144
 145     return $slave
 146 }
 147
 148 proc ::safe::TkInit {interpPath} {
 149     variable tkInit
 150     if {[info exists tkInit($interpPath)]} {
 151         set value $tkInit($interpPath)
 152         Log $interpPath "TkInit called, returning \"$value\"" NOTICE
 153         return $value
 154     } else {
 155         Log $interpPath "TkInit called for interp with clearance:\
 156                 preventing Tk init" ERROR
 157         error "not allowed"
 158     }
 159 }
 160
 161 # safe::allowTk --
 162 #
 163 #       Set tkInit(interpPath) to allow Tk to be initialized in
 164 #       safe::TkInit.
 165 #
 166 # Arguments:
 167 #       interpPath      slave interpreter handle
 168 #       argv            arguments passed to safe::TkInterpInit
 169 #
 170 # Results:
 171 #       none.
 172
 173 proc ::safe::allowTk {interpPath argv} {
 174     variable tkInit
 175     set tkInit($interpPath) $argv
 176     return
 177 }
 178
 179
 180 # safe::disallowTk --
 181 #
 182 #       Unset tkInit(interpPath) to disallow Tk from getting initialized
 183 #       in safe::TkInit.
 184 #
 185 # Arguments:
 186 #       interpPath      slave interpreter handle
 187 #
 188 # Results:
 189 #       none.
 190
 191 proc ::safe::disallowTk {interpPath} {
 192     variable tkInit
 193     # This can already be deleted by the DeleteHook of the interp
 194     if {[info exists tkInit($interpPath)]} {
 195         unset tkInit($interpPath)
 196     }
 197     return
 198 }
 199
 200
 201 # safe::tkDelete --
 202 #
 203 #       Clean up the window associated with the interp being deleted.
 204 #
 205 # Arguments:
 206 #       interpPath      slave interpreter handle
 207 #
 208 # Results:
 209 #       none.
 210
 211 proc ::safe::tkDelete {W window slave} {
 212
 213     # we are going to be called for each widget... skip untill it's
 214     # top level
 215
 216     Log $slave "Called tkDelete $W $window" NOTICE
 217     if {[::interp exists $slave]} {
 218         if {[catch {::safe::interpDelete $slave} msg]} {
 219             Log $slave "Deletion error : $msg"
 220         }
 221     }
 222     if {[winfo exists $window]} {
 223         Log $slave "Destroy toplevel $window" NOTICE
 224         destroy $window
 225     }
 226
 227     # clean up tkInit(slave)
 228     disallowTk $slave
 229     return
 230 }
 231
 232 proc ::safe::tkTopLevel {slave display} {
 233     variable tkSafeId
 234     incr tkSafeId
 235     set w ".safe$tkSafeId"
 236     if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
 237         return -code error "Unable to create toplevel for\
 238                 safe slave \"$slave\" ($msg)"
 239     }
 240     Log $slave "New toplevel $w" NOTICE
 241
 242     set msg "Untrusted Tcl applet ($slave)"
 243     wm title $w $msg
 244
 245     # Control frame
 246     set wc $w.fc
 247     frame $wc -bg red -borderwidth 3 -relief ridge
 248
 249     # We will destroy the interp when the window is destroyed
 250     bindtags $wc [concat Safe$wc [bindtags $wc]]
 251     bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave]
 252
 253     label $wc.l -text $msg -padx 2 -pady 0 -anchor w
 254
 255     # We want the button to be the last visible item
 256     # (so be packed first) and at the right and not resizing horizontally
 257
 258     # frame the button so it does not expand horizontally
 259     # but still have the default background instead of red one from the parent
 260     frame  $wc.fb -bd 0
 261     button $wc.fb.b -text "Delete" \
 262             -bd 1  -padx 2 -pady 0 -highlightthickness 0 \
 263             -command [list ::safe::tkDelete $w $w $slave]
 264     pack $wc.fb.b -side right -fill both
 265     pack $wc.fb -side right -fill both -expand 1
 266     pack $wc.l -side left  -fill both -expand 1
 267     pack $wc -side bottom -fill x
 268
 269     # Container frame
 270     frame $w.c -container 1
 271     pack $w.c -fill both -expand 1
 272
 273     # return both the toplevel window name and the id to use for embedding
 274     list $w [winfo id $w.c]
 275 }
 276
 277 }