home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / tcltk / tk8.5 / safetk.tcl < prev    next >
Encoding:
Text File  |  2009-11-17  |  7.1 KB  |  263 lines

  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. }
  263.