home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tk8.4 / safetk.tcl < prev    next >
Text File  |  2000-10-30  |  8KB  |  278 lines
  1. # safetk.tcl --
  2. #
  3. # Support procs to use Tk in safe interpreters.
  4. #
  5. # RCS: @(#) $Id: safetk.tcl,v 1.8 2000/10/31 01:11:51 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.     # 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 {[string compare $nDisplay $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. }
  278.