]> cvs.zerfleddert.de Git - micropolis/blame_incremental - src/tk/library/menu.tcl
still more NumLock fixes, this time for scrollbars and sliders
[micropolis] / src / tk / library / menu.tcl
... / ...
CommitLineData
1# menu.tcl --
2#
3# This file contains Tcl procedures used to manage Tk menus and
4# menubuttons. Most of the code here is dedicated to support for
5# menu traversal via the keyboard.
6#
7# $Header: /user6/ouster/wish/scripts/RCS/menu.tcl,v 1.11 92/08/08 14:49:55 ouster Exp $ SPRITE (Berkeley)
8#
9# Copyright 1992 Regents of the University of California
10# Permission to use, copy, modify, and distribute this
11# software and its documentation for any purpose and without
12# fee is hereby granted, provided that this copyright
13# notice appears in all copies. The University of California
14# makes no representations about the suitability of this
15# software for any purpose. It is provided "as is" without
16# express or implied warranty.
17#
18
19# The procedure below is publically available. It is used to indicate
20# the menus associated with a particular top-level window, for purposes
21# of keyboard menu traversal. Its first argument is the path name of
22# a top-level window, and any additional arguments are the path names of
23# the menu buttons associated with that top-level window, in the order
24# they should be traversed. If no menu buttons are named, the procedure
25# returns the current list of menus for w. If a single empty string is
26# supplied, then the menu list for w is cancelled. Otherwise, tk_menus
27# sets the menu list for w to the menu buttons.
28
29proc tk_menus {w args} {
30 global tk_priv
31
32 if {$args == ""} {
33 if [catch {set result [set tk_priv(menusFor$w)]}] {
34 return ""
35 }
36 return $result
37 }
38
39 if {$args == "{}"} {
40 catch {unset tk_priv(menusFor$w)}
41 return ""
42 }
43
44 set tk_priv(menusFor$w) $args
45}
46
47# The procedure below is publically available. It takes any number of
48# arguments taht are names of widgets or classes. It sets up bindings
49# for the widgets or classes so that keyboard menu traversal is possible
50# when the input focus is in those widgets or classes.
51
52proc tk_bindForTraversal args {
53 foreach w $args {
54 bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
55 bind $w <F10> {tk_firstMenu %W}
56 }
57}
58
59# The procedure below does all of the work of posting a menu (including
60# unposting any other menu that might currently be posted). The "w"
61# argument is the name of the menubutton for the menu to be posted.
62# Note: if $w is disabled then the procedure does nothing.
63
64proc tk_mbPost {w} {
65 global tk_priv tk_strictMotif
66 if {[lindex [$w config -state] 4] == "disabled"} {
67 return
68 }
69 set cur $tk_priv(posted)
70 if {$cur == $w} {
71 return
72 }
73 if {$cur != ""} tk_mbUnpost
74 set tk_priv(relief) [lindex [$w config -relief] 4]
75 $w config -relief raised
76 set tk_priv(cursor) [lindex [$w config -cursor] 4]
77 $w config -cursor arrow
78 $w post
79 grab -global $w
80 set tk_priv(posted) $w
81 if {$tk_priv(focus) == ""} {
82 set tk_priv(focus) [focus]
83 }
84 set menu [lindex [$w config -menu] 4]
85 set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
86 set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
87 if $tk_strictMotif {
88 $menu config -activebackground [lindex [$menu config -background] 4]
89 $menu config -activeforeground [lindex [$menu config -foreground] 4]
90 }
91 focus $menu
92}
93
94# The procedure below does all the work of unposting the menubutton that's
95# currently posted. It takes no arguments.
96
97proc tk_mbUnpost {} {
98 global tk_priv
99 if {$tk_priv(posted) != ""} {
100 $tk_priv(posted) config -relief $tk_priv(relief)
101 $tk_priv(posted) config -cursor $tk_priv(cursor)
102 $tk_priv(posted) config -activebackground $tk_priv(activeBg)
103 $tk_priv(posted) config -activeforeground $tk_priv(activeFg)
104 $tk_priv(posted) unpost
105# deh multi display bug fix
106# grab none
107 set menu [lindex [$tk_priv(posted) config -menu] 4]
108 grab -off $menu
109 focus $tk_priv(focus)
110 set tk_priv(focus) ""
111 $menu config -activebackground $tk_priv(activeBg)
112 $menu config -activeforeground $tk_priv(activeFg)
113 set tk_priv(posted) {}
114 }
115}
116
117# The procedure below is invoked to implement keyboard traversal to
118# a menu button. It takes two arguments: the name of a window where
119# a keystroke originated, and the ascii character that was typed.
120# This procedure finds a menu bar by looking upward for a top-level
121# window, then looking for a window underneath that named "menu".
122# Then it searches through all the subwindows of "menu" for a menubutton
123# with an underlined character matching char. If one is found, it
124# posts that menu.
125
126proc tk_traverseToMenu {w char} {
127 global tk_priv
128 if {$char == ""} {
129 return
130 }
131 set char [string tolower $char]
132
133 foreach mb [tk_getMenuButtons $w] {
134 if {[winfo class $mb] == "Menubutton"} {
135 set char2 [string index [lindex [$mb config -text] 4] \
136 [lindex [$mb config -underline] 4]]
137 if {[string compare $char [string tolower $char2]] == 0} {
138 tk_mbPost $mb
139 [lindex [$mb config -menu] 4] activate 0
140 return
141 }
142 }
143 }
144}
145
146# The procedure below is used to implement keyboard traversal within
147# the posted menu. It takes two arguments: the name of the menu to
148# be traversed within, and an ASCII character. It searches for an
149# entry in the menu that has that character underlined. If such an
150# entry is found, it is invoked and the menu is unposted.
151
152proc tk_traverseWithinMenu {w char} {
153 if {$char == ""} {
154 return
155 }
156 set char [string tolower $char]
157 set last [$w index last]
158 for {set i 0} {$i <= $last} {incr i} {
159 if [catch {set char2 [string index \
160 [lindex [$w entryconfig $i -label] 4] \
161 [lindex [$w entryconfig $i -underline] 4]]}] {
162 continue
163 }
164 if {[string compare $char [string tolower $char2]] == 0} {
165 tk_mbUnpost
166 $w invoke $i
167 return
168 }
169 }
170}
171
172# The procedure below takes a single argument, which is the name of
173# a window. It returns a list containing path names for all of the
174# menu buttons associated with that window's top-level window, or an
175# empty list if there are none.
176
177proc tk_getMenuButtons w {
178 global tk_priv
179 set top [winfo toplevel $w]
180 if [catch {set buttons [set tk_priv(menusFor$top)]}] {
181 return ""
182 }
183 return $buttons
184}
185
186# The procedure below is used to traverse to the next or previous
187# menu in a menu bar. It takes one argument, which is a count of
188# how many menu buttons forward or backward (if negative) to move.
189# If there is no posted menu then this procedure has no effect.
190
191proc tk_nextMenu count {
192 global tk_priv
193 if {$tk_priv(posted) == ""} {
194 return
195 }
196 set buttons [tk_getMenuButtons $tk_priv(posted)]
197 set length [llength $buttons]
198 for {set i 0} 1 {incr i} {
199 if {$i >= $length} {
200 return
201 }
202 if {[lindex $buttons $i] == $tk_priv(posted)} {
203 break
204 }
205 }
206 incr i $count
207 while 1 {
208 while {$i < 0} {
209 incr i $length
210 }
211 while {$i >= $length} {
212 incr i -$length
213 }
214 set mb [lindex $buttons $i]
215 if {[lindex [$mb configure -state] 4] != "disabled"} {
216 break
217 }
218 incr i $count
219 }
220 tk_mbUnpost
221 tk_mbPost $mb
222 [lindex [$mb config -menu] 4] activate 0
223}
224
225# The procedure below is used to traverse to the next or previous entry
226# in the posted menu. It takes one argument, which is 1 to go to the
227# next entry or -1 to go to the previous entry. Disabled entries are
228# skipped in this process.
229
230proc tk_nextMenuEntry count {
231 global tk_priv
232 if {$tk_priv(posted) == ""} {
233 return
234 }
235 set menu [lindex [$tk_priv(posted) config -menu] 4]
236 set length [expr [$menu index last]+1]
237 set i [$menu index active]
238 if {$i == "none"} {
239 set i 0
240 } else {
241 incr i $count
242 }
243 while 1 {
244 while {$i < 0} {
245 incr i $length
246 }
247 while {$i >= $length} {
248 incr i -$length
249 }
250 if {[catch {$menu entryconfigure $i -state} state] == 0} {
251 if {[lindex $state 4] != "disabled"} {
252 break
253 }
254 }
255 incr i $count
256 }
257 $menu activate $i
258}
259
260# The procedure below invokes the active entry in the posted menu,
261# if there is one. Otherwise it does nothing.
262
263proc tk_invokeMenu {menu} {
264 set i [$menu index active]
265 if {$i != "none"} {
266 tk_mbUnpost
267 update idletasks
268 $menu invoke $i
269 }
270}
271
272# The procedure below is invoked to keyboard-traverse to the first
273# menu for a given source window. The source window is passed as
274# parameter.
275
276proc tk_firstMenu w {
277 set mb [lindex [tk_getMenuButtons $w] 0]
278 if {$mb != ""} {
279 tk_mbPost $mb
280 [lindex [$mb config -menu] 4] activate 0
281 }
282}
283
284# The procedure below is invoked when a button-1-down event is
285# received by a menu button. If the mouse is in the menu button
286# then it posts the button's menu. If the mouse isn't in the
287# button's menu, then it deactivates any active entry in the menu.
288# Remember, event-sharing can cause this procedure to be invoked
289# for two different menu buttons on the same event.
290
291proc tk_mbButtonDown w {
292 global tk_priv
293 if {[lindex [$w config -state] 4] == "disabled"} {
294 return
295 }
296 if {$tk_priv(inMenuButton) == $w} {
297 tk_mbPost $w
298 }
299 set menu [lindex [$tk_priv(posted) config -menu] 4]
300 if {$tk_priv(window) != $menu} {
301 $menu activate none
302 }
303}
Impressum, Datenschutz