1# tearoff.tcl -- 2# 3# This file contains procedures that implement tear-off menus. 4# 5# RCS: @(#) $Id$ 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 \ 50 || [winfo class $parent] eq "Menu"} { 51 set parent [winfo parent $parent] 52 } 53 if {$parent eq "."} { 54 set parent "" 55 } 56 for {set i 1} 1 {incr i} { 57 set menu $parent.tearoff$i 58 if {![winfo exists $menu]} { 59 break 60 } 61 } 62 63 $w clone $menu tearoff 64 65 # Pick a title for the new menu by looking at the parent of the 66 # original: if the parent is a menu, then use the text of the active 67 # entry. If it's a menubutton then use its text. 68 69 set parent [winfo parent $w] 70 if {[$menu cget -title] ne ""} { 71 wm title $menu [$menu cget -title] 72 } else { 73 switch -- [winfo class $parent] { 74 Menubutton { 75 wm title $menu [$parent cget -text] 76 } 77 Menu { 78 wm title $menu [$parent entrycget active -label] 79 } 80 } 81 } 82 83 if {[tk windowingsystem] eq "win32"} { 84 wm transient $menu [winfo toplevel $parent] 85 wm attributes $menu -toolwindow 1 86 } 87 88 $menu post $x $y 89 90 if {[winfo exists $menu] == 0} { 91 return "" 92 } 93 94 # Set tk::Priv(focus) on entry: otherwise the focus will get lost 95 # after keyboard invocation of a sub-menu (it will stay on the 96 # submenu). 97 98 bind $menu <Enter> { 99 set tk::Priv(focus) %W 100 } 101 102 # If there is a -tearoffcommand option for the menu, invoke it 103 # now. 104 105 set cmd [$w cget -tearoffcommand] 106 if {$cmd ne ""} { 107 uplevel #0 $cmd [list $w $menu] 108 } 109 return $menu 110} 111 112# ::tk::MenuDup -- 113# Given a menu (hierarchy), create a duplicate menu (hierarchy) 114# in a given window. 115# 116# Arguments: 117# src - Source window. Must be a menu. It and its 118# menu descendants will be duplicated at dst. 119# dst - Name to use for topmost menu in duplicate 120# hierarchy. 121 122proc ::tk::MenuDup {src dst type} { 123 set cmd [list menu $dst -type $type] 124 foreach option [$src configure] { 125 if {[llength $option] == 2} { 126 continue 127 } 128 if {[lindex $option 0] eq "-type"} { 129 continue 130 } 131 lappend cmd [lindex $option 0] [lindex $option 4] 132 } 133 eval $cmd 134 set last [$src index last] 135 if {$last eq "none"} { 136 return 137 } 138 for {set i [$src cget -tearoff]} {$i <= $last} {incr i} { 139 set cmd [list $dst add [$src type $i]] 140 foreach option [$src entryconfigure $i] { 141 lappend cmd [lindex $option 0] [lindex $option 4] 142 } 143 eval $cmd 144 } 145 146 # Duplicate the binding tags and bindings from the source menu. 147 148 set tags [bindtags $src] 149 set srcLen [string length $src] 150 151 # Copy tags to x, replacing each substring of src with dst. 152 153 while {[set index [string first $src $tags]] != -1} { 154 append x [string range $tags 0 [expr {$index - 1}]]$dst 155 set tags [string range $tags [expr {$index + $srcLen}] end] 156 } 157 append x $tags 158 159 bindtags $dst $x 160 161 foreach event [bind $src] { 162 unset x 163 set script [bind $src $event] 164 set eventLen [string length $event] 165 166 # Copy script to x, replacing each substring of event with dst. 167 168 while {[set index [string first $event $script]] != -1} { 169 append x [string range $script 0 [expr {$index - 1}]] 170 append x $dst 171 set script [string range $script [expr {$index + $eventLen}] end] 172 } 173 append x $script 174 175 bind $dst $event $x 176 } 177} 178