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