mingw/lib/tk8.5/safetk.tcl

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