mingw/lib/tk8.5/safetk.tcl

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