]> git.zerfleddert.de Git - micropolis/blob - src/tk/library/menu.tcl
XINCLUDE: use /usr/X11R6/include everywhere
[micropolis] / src / tk / library / menu.tcl
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
29 proc 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
52 proc 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
64 proc 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
97 proc 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
126 proc 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
152 proc 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
177 proc 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
191 proc 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
230 proc 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
263 proc 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
276 proc 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
291 proc 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