home *** CD-ROM | disk | FTP | other *** search
/ Chip: Linux Special / CorelLinux_CHIP.iso / VMware / bin / vmware-wizard / lib / tk8.0 / safetk.tcl < prev    next >
Encoding:
Text File  |  1999-02-24  |  6.1 KB  |  205 lines
  1. # safetk.tcl --
  2. #
  3. # Support procs to use Tk in safe interpreters.
  4. #
  5. # RCS: @(#) $Id: safetk.tcl,v 1.3 1998/09/14 18:23:24 stanton 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.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.     # Clear Tk's access for that interp (path).
  41.     allowTk $slave $argv
  42.  
  43.     # there seems to be an obscure case where the tk_library
  44.     # variable value is changed to point to a sym link destination
  45.     # dir instead of the sym link itself, and thus where the $tk_library
  46.     # would then not be anymore one of the auto_path dir, so we use
  47.     # the addToAccessPath which adds if it's not already in instead
  48.     # of the more conventional findInAccessPath.
  49.     # Might be usefull for masters without Tk really loaded too.
  50.     ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
  51.     return $slave;
  52.     }
  53.  
  54.  
  55. # tkInterpLoadTk : 
  56. # Do additional configuration as needed (calling tkInterpInit) 
  57. # and actually load Tk into the slave.
  58. # 
  59. # Either contained in the specified windowId (-use) or
  60. # creating a decorated toplevel for it.
  61.  
  62. # empty definition for auto_mkIndex
  63. proc ::safe::loadTk {} {}
  64.    
  65.     ::tcl::OptProc loadTk {
  66.     {slave -interp "name of the slave interpreter"}
  67.     {-use  -windowId {} "window Id to use (new toplevel otherwise)"}
  68.     {-display -displayName {} "display name to use (current one otherwise)"}
  69.     } {
  70.     set displayGiven [::tcl::OptProcArgGiven "-display"]
  71.     if {!$displayGiven} {
  72.         # Try to get the current display from "."
  73.         # (which might not exist if the master is tk-less)
  74.         if {[catch {set display [winfo screen .]}]} {
  75.         if {[info exists ::env(DISPLAY)]} {
  76.             set display $::env(DISPLAY)
  77.         } else {
  78.             Log $slave "no winfo screen . nor env(DISPLAY)" WARNING
  79.             set display ":0.0"
  80.         }
  81.         }
  82.     }
  83.     if {![::tcl::OptProcArgGiven "-use"]} {
  84.         # create a decorated toplevel
  85.         ::tcl::Lassign [tkTopLevel $slave $display] w use;
  86.         # set our delete hook (slave arg is added by interpDelete)
  87.         Set [DeleteHookName $slave] [list tkDelete {} $w];
  88.     } else {
  89.         # Let's be nice and also accept tk window names instead of ids
  90.         if {[string match ".*" $use]} {
  91.         set windowName $use
  92.         set use [winfo id $windowName]
  93.         set nDisplay [winfo screen $windowName]
  94.         } else {
  95.         # Check for a better -display value
  96.         # (works only for multi screens on single host, but not
  97.         #  cross hosts, for that a tk window name would be better
  98.         #  but embeding is also usefull for non tk names)
  99.         if {![catch {winfo pathname $use} name]} {
  100.             set nDisplay [winfo screen $name]
  101.         } else {
  102.             # Can't have a better one
  103.             set nDisplay $display
  104.         }
  105.         }
  106.         if {[string compare $nDisplay $display]} {
  107.         if {$displayGiven} {
  108.             error "conflicting -display $display and -use\
  109.                 $use -> $nDisplay"
  110.         } else {
  111.             set display $nDisplay
  112.         }
  113.         }
  114.     }
  115.  
  116.     # Prepares the slave for tk with those parameters
  117.  
  118.     tkInterpInit $slave [list "-use" $use "-display" $display]
  119.  
  120.     load {} Tk $slave
  121.  
  122.     return $slave
  123.     }
  124.  
  125. proc ::safe::TkInit {interpPath} {
  126.     variable tkInit
  127.     if {[info exists tkInit($interpPath)]} {
  128.     set value $tkInit($interpPath)
  129.     Log $interpPath "TkInit called, returning \"$value\"" NOTICE
  130.     return $value
  131.     } else {
  132.     Log $interpPath "TkInit called for interp with clearance:\
  133.         preventing Tk init" ERROR
  134.     error "not allowed"
  135.     }
  136. }
  137.  
  138. proc ::safe::allowTk {interpPath argv} {
  139.     variable tkInit
  140.     set tkInit($interpPath) $argv
  141. }
  142.  
  143.     proc ::safe::tkDelete {W window slave} {
  144.     # we are going to be called for each widget... skip untill it's
  145.     # top level
  146.     Log $slave "Called tkDelete $W $window" NOTICE;
  147.     if {[::interp exists $slave]} {
  148.         if {[catch {::safe::interpDelete $slave} msg]} {
  149.         Log $slave "Deletion error : $msg";
  150.         }
  151.     }
  152.     if {[winfo exists $window]} {
  153.         Log $slave "Destroy toplevel $window" NOTICE;
  154.         destroy $window;
  155.     }
  156.     }
  157.  
  158. proc ::safe::tkTopLevel {slave display} {
  159.     variable tkSafeId;
  160.     incr tkSafeId;
  161.     set w ".safe$tkSafeId";
  162.     if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
  163.     return -code error "Unable to create toplevel for\
  164.         safe slave \"$slave\" ($msg)";
  165.     }
  166.     Log $slave "New toplevel $w" NOTICE
  167.  
  168.     set msg "Untrusted Tcl applet ($slave)"
  169.     wm title $w $msg;
  170.  
  171.     # Control frame
  172.     set wc $w.fc
  173.     frame $wc -bg red -borderwidth 3 -relief ridge ;
  174.  
  175.     # We will destroy the interp when the window is destroyed
  176.     bindtags $wc [concat Safe$wc [bindtags $wc]]
  177.     bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave];
  178.  
  179.     label $wc.l -text $msg \
  180.         -padx 2 -pady 0 -anchor w;
  181.  
  182.     # We want the button to be the last visible item
  183.     # (so be packed first) and at the right and not resizing horizontally
  184.  
  185.     # frame the button so it does not expand horizontally
  186.     # but still have the default background instead of red one from the parent
  187.     frame  $wc.fb -bd 0 ;
  188.     button $wc.fb.b -text "Delete" \
  189.         -bd 1  -padx 2 -pady 0 -highlightthickness 0 \
  190.         -command [list ::safe::tkDelete $w $w $slave]
  191.     pack $wc.fb.b -side right -fill both ;
  192.     pack $wc.fb -side right -fill both -expand 1;
  193.     pack $wc.l -side left  -fill both -expand 1;
  194.     pack $wc -side bottom -fill x ;
  195.  
  196.     # Container frame
  197.     frame $w.c -container 1;
  198.     pack $w.c -fill both -expand 1;
  199.     
  200.     # return both the toplevel window name and the id to use for embedding
  201.     list $w [winfo id $w.c] ;
  202. }
  203.  
  204. }
  205.