"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/tk8.6/safetk.tcl" (17 Mar 2020, 7381 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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     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     } else {
   94     # set our delete hook (slave arg is added by interpDelete)
   95     # to clean up tkInit(slave)
   96     set state(cleanupHook) [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         return -code error -errorcode {TK DISPLAY SAFE} \
  118             "conflicting -display $display and -use $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     return -code error -errorcode {TK SAFE PERMISSION} "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 -errorcode {TK TOPLEVEL SAFE} \
  223         "Unable to create toplevel for 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 }