tearoff.tcl (5142B)
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"} { 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]] != -1} { 157 append x [string range $tags 0 [expr {$index - 1}]]$dst 158 set tags [string range $tags [expr {$index + $srcLen}] end] 159 } 160 append x $tags 161 162 bindtags $dst $x 163 164 foreach event [bind $src] { 165 unset x 166 set script [bind $src $event] 167 set eventLen [string length $event] 168 169 # Copy script to x, replacing each substring of event with dst. 170 171 while {[set index [string first $event $script]] != -1} { 172 append x [string range $script 0 [expr {$index - 1}]] 173 append x $dst 174 set script [string range $script [expr {$index + $eventLen}] end] 175 } 176 append x $script 177 178 bind $dst $event $x 179 } 180 }