util/src/TclTk/tk8.6.12/library/tearoff.tcl

   1 # tearoff.tcl --
   2 #
   3 # This file contains procedures that implement tear-off menus.
   4 #
   5 # Copyright (c) 1994 The Regents of the University of California.
   6 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
   7 #
   8 # See the file "license.terms" for information on usage and redistribution
   9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10 #
  11
  12 # ::tk::TearoffMenu --
  13 # Given the name of a menu, this procedure creates a torn-off menu
  14 # that is identical to the given menu (including nested submenus).
  15 # The new torn-off menu exists as a toplevel window managed by the
  16 # window manager.  The return value is the name of the new menu.
  17 # The window is created at the point specified by x and y
  18 #
  19 # Arguments:
  20 # w -                   The menu to be torn-off (duplicated).
  21 # x -                   x coordinate where window is created
  22 # y -                   y coordinate where window is created
  23
  24 proc ::tk::TearOffMenu {w {x 0} {y 0}} {
  25     # Find a unique name to use for the torn-off menu.  Find the first
  26     # ancestor of w that is a toplevel but not a menu, and use this as
  27     # the parent of the new menu.  This guarantees that the torn off
  28     # menu will be on the same screen as the original menu.  By making
  29     # it a child of the ancestor, rather than a child of the menu, it
  30     # can continue to live even if the menu is deleted;  it will go
  31     # away when the toplevel goes away.
  32
  33     if {$x == 0} {
  34         set x [winfo rootx $w]
  35     }
  36     if {$y == 0} {
  37         set y [winfo rooty $w]
  38         if {[tk windowingsystem] eq "aqua"} {
  39             # Shift by height of tearoff entry minus height of window titlebar
  40             catch {incr y [expr {[$w yposition 1] - 16}]}
  41             # Avoid the native menu bar which sits on top of everything.
  42             if {$y < 22} {set y 22}
  43         }
  44     }
  45
  46     set parent [winfo parent $w]
  47     while {[winfo toplevel $parent] ne $parent \
  48             || [winfo class $parent] eq "Menu"} {
  49         set parent [winfo parent $parent]
  50     }
  51     if {$parent eq "."} {
  52         set parent ""
  53     }
  54     for {set i 1} 1 {incr i} {
  55         set menu $parent.tearoff$i
  56         if {![winfo exists $menu]} {
  57             break
  58         }
  59     }
  60
  61     $w clone $menu tearoff
  62
  63     # Pick a title for the new menu by looking at the parent of the
  64     # original: if the parent is a menu, then use the text of the active
  65     # entry.  If it's a menubutton then use its text.
  66
  67     set parent [winfo parent $w]
  68     if {[$menu cget -title] ne ""} {
  69         wm title $menu [$menu cget -title]
  70     } else {
  71         switch -- [winfo class $parent] {
  72             Menubutton {
  73                 wm title $menu [$parent cget -text]
  74             }
  75             Menu {
  76                 wm title $menu [$parent entrycget active -label]
  77             }
  78         }
  79     }
  80
  81     if {[tk windowingsystem] eq "win32"} {
  82         # [Bug 3181181]: Find the toplevel window for the menu
  83         set parent [winfo toplevel $parent]
  84         while {[winfo class $parent] eq "Menu"} {
  85             set parent [winfo toplevel [winfo parent $parent]]
  86         }
  87         wm transient $menu [winfo toplevel $parent]
  88         wm attributes $menu -toolwindow 1
  89     }
  90
  91     $menu post $x $y
  92
  93     if {[winfo exists $menu] == 0} {
  94         return ""
  95     }
  96
  97     # Set tk::Priv(focus) on entry:  otherwise the focus will get lost
  98     # after keyboard invocation of a sub-menu (it will stay on the
  99     # submenu).
 100
 101     bind $menu <Enter> {
 102         set tk::Priv(focus) %W
 103     }
 104
 105     # If there is a -tearoffcommand option for the menu, invoke it
 106     # now.
 107
 108     set cmd [$w cget -tearoffcommand]
 109     if {$cmd ne ""} {
 110         uplevel #0 $cmd [list $w $menu]
 111     }
 112     return $menu
 113 }
 114
 115 # ::tk::MenuDup --
 116 # Given a menu (hierarchy), create a duplicate menu (hierarchy)
 117 # in a given window.
 118 #
 119 # Arguments:
 120 # src -                 Source window.  Must be a menu.  It and its
 121 #                       menu descendants will be duplicated at dst.
 122 # dst -                 Name to use for topmost menu in duplicate
 123 #                       hierarchy.
 124
 125 proc ::tk::MenuDup {src dst type} {
 126     set cmd [list menu $dst -type $type]
 127     foreach option [$src configure] {
 128         if {[llength $option] == 2} {
 129             continue
 130         }
 131         if {[lindex $option 0] eq "-type"} {
 132             continue
 133         }
 134         lappend cmd [lindex $option 0] [lindex $option 4]
 135     }
 136     eval $cmd
 137     set last [$src index last]
 138     if {$last eq "none" || $last < 0} {
 139         return
 140     }
 141     for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
 142         set cmd [list $dst add [$src type $i]]
 143         foreach option [$src entryconfigure $i]  {
 144             lappend cmd [lindex $option 0] [lindex $option 4]
 145         }
 146         eval $cmd
 147     }
 148
 149     # Duplicate the binding tags and bindings from the source menu.
 150
 151     set tags [bindtags $src]
 152     set srcLen [string length $src]
 153
 154     # Copy tags to x, replacing each substring of src with dst.
 155
 156     while {[set index [string first $src $tags]] >= 0} {
 157         if {$index > 0} {
 158             append x [string range $tags 0 $index-1]$dst
 159         }
 160         set tags [string range $tags $index+$srcLen end]
 161     }
 162     append x $tags
 163
 164     bindtags $dst $x
 165
 166     foreach event [bind $src] {
 167         unset x
 168         set script [bind $src $event]
 169         set eventLen [string length $event]
 170
 171         # Copy script to x, replacing each substring of event with dst.
 172
 173         while {[set index [string first $event $script]] >= 0} {
 174             if {$index > 0} {
 175                 append x [string range $script 0 $index-1]
 176             }
 177             append x $dst
 178             set script [string range $script $index+$eventLen end]
 179         }
 180         append x $script
 181
 182         bind $dst $event $x
 183     }
 184 }