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