home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / library / tearoff.tcl < prev    next >
Encoding:
Text File  |  1995-06-08  |  3.4 KB  |  122 lines
  1. # tearoff.tcl --
  2. #
  3. # This file contains procedures that implement tear-off menus.
  4. #
  5. # @(#) tearoff.tcl 1.5 95/04/23 16:50:06
  6. #
  7. # Copyright (c) 1994 The Regents of the University of California.
  8. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14. # tkTearoffMenu --
  15. # Given the name of a menu, this procedure creates a torn-off menu
  16. # that is identical to the given menu (including nested submenus).
  17. # The new torn-off menu exists as a toplevel window managed by the
  18. # window manager.  The return value is the name of the new menu.
  19. #
  20. # Arguments:
  21. # w -            The menu to be torn-off (duplicated).
  22.  
  23. proc tkTearOffMenu w {
  24.     # Find a unique name to use for the torn-off menu.  Find the first
  25.     # ancestor of w that is a toplevel but not a menu, and use this as
  26.     # the parent of the new menu.  This guarantees that the torn off
  27.     # menu will be on the same screen as the original menu.  By making
  28.     # it a child of the ancestor, rather than a child of the menu, it
  29.     # can continue to live even if the menu is deleted;  it will go
  30.     # away when the toplevel goes away.
  31.  
  32.     set parent [winfo parent $w]
  33.     while {([winfo toplevel $parent] != $parent)
  34.         || ([winfo class $parent] == "Menu")} {
  35.     set parent [winfo parent $parent]
  36.     }
  37.     if {$parent == "."} {
  38.     set parent ""
  39.     }
  40.     for {set i 1} 1 {incr i} {
  41.     set menu $parent.tearoff$i
  42.     if ![winfo exists $menu] {
  43.         break
  44.     }
  45.     }
  46.  
  47.     tkMenuDup $w $menu
  48.     wm overrideredirect $menu 0
  49.  
  50.     # Pick a title for the new menu by looking at the parent of the
  51.     # original: if the parent is a menu, then use the text of the active
  52.     # entry.  If it's a menubutton then use its text.
  53.  
  54.     set parent [winfo parent $w]
  55.     switch [winfo class $parent] {
  56.     Menubutton {
  57.         wm title $menu [$parent cget -text]
  58.     }
  59.     Menu {
  60.         wm title $menu [$parent entrycget active -label]
  61.     }
  62.     }
  63.  
  64.     $menu configure -tearoff 0
  65.     $menu post [winfo x $w] [winfo y $w]
  66.  
  67.     # Set tkPriv(focus) on entry:  otherwise the focus will get lost
  68.     # after keyboard invocation of a sub-menu (it will stay on the
  69.     # submenu).
  70.  
  71.     bind $menu <Enter> {
  72.     set tkPriv(focus) %W
  73.     }
  74. }
  75.  
  76. # tkMenuDup --
  77. # Given a menu (hierarchy), create a duplicate menu (hierarchy)
  78. # in a given window.
  79. #
  80. # Arguments:
  81. # src -            Source window.  Must be a menu.  It and its
  82. #            menu descendants will be duplicated at dst.
  83. # dst -            Name to use for topmost menu in duplicate
  84. #            hierarchy.
  85.  
  86. proc tkMenuDup {src dst} {
  87.     set cmd "menu $dst"
  88.     foreach option [$src configure] {
  89.     if {[llength $option] == 2} {
  90.         continue
  91.     }
  92.     lappend cmd [lindex $option 0] [lindex $option 4]
  93.     }
  94.     eval $cmd
  95.     set last [$src index last]
  96.     if {$last == "none"} {
  97.     return
  98.     }
  99.     for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
  100.     set cmd "$dst add [$src type $i]"
  101.     foreach option [$src entryconfigure $i]  {
  102.         lappend cmd [lindex $option 0] [lindex $option 4]
  103.     }
  104.     eval $cmd
  105.     if {[$src type $i] == "cascade"} {
  106.         tkMenuDup [$src entrycget $i -menu] $dst.m$i
  107.         $dst entryconfigure $i -menu $dst.m$i
  108.     }
  109.     }
  110.  
  111.     # Duplicate the binding tags and bindings from the source menu.
  112.  
  113.     regsub -all . $src {\\&} quotedSrc
  114.     regsub -all . $dst {\\&} quotedDst
  115.     regsub -all $quotedSrc [bindtags $src] $dst x
  116.     bindtags $dst $x
  117.     foreach event [bind $src] {
  118.     regsub -all $quotedSrc [bind $src $event] $dst x
  119.     bind $dst $event $x
  120.     }
  121. }
  122.