]> git.zerfleddert.de Git - micropolis/blob - res/menu.tcl
ea9e13e87901c721dc18c0369cac4525436242c0
[micropolis] / res / 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 # Variables used by menu buttons:
30 # $tk_priv(posted@$screen) - keeps track of the menubutton whose menu is
31 # currently posted (or empty string, if none).
32 # $tk_priv(inMenuButton@$screen)-
33 # if non-null, identifies menu button
34 # containing mouse pointer.
35 # $tk_priv(relief@$screen) - keeps track of original relief of posted
36 # menu button, so it can be restored later.
37 # $tk_priv(dragging@$screen) - if non-null, identifies menu button whose
38 # menu is currently being dragged in a tear-off
39 # operation.
40 # $tk_priv(focus@$screen) - records old focus window so focus can be
41 # returned there after keyboard traversal
42 # to menu.
43 #
44 # Variables used by menus:
45 # $tk_priv(x@$screen) and $tk_priv(y@$screen) are used to keep
46 # track of the position of the mouse cursor in the menu window
47 # during dragging of tear-off menus. $tk_priv(window) keeps track
48 # of the menu containing the mouse, if any.
49
50 proc tk_menus {w args} {
51 global tk_priv
52
53 if {$args == ""} {
54 if [catch {set result [set tk_priv(menusFor$w)]}] {
55 return ""
56 }
57 return $result
58 }
59
60 if {$args == "{}"} {
61 catch {unset tk_priv(menusFor$w)}
62 return ""
63 }
64
65 append tk_priv(menusFor$w) " $args"
66 }
67
68 # The procedure below is publically available. It takes any number of
69 # arguments taht are names of widgets or classes. It sets up bindings
70 # for the widgets or classes so that keyboard menu traversal is possible
71 # when the input focus is in those widgets or classes.
72
73 proc tk_bindForTraversal args {
74 foreach w $args {
75 bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
76 bind $w <F10> {tk_firstMenu %W}
77 }
78 }
79
80 # The procedure below does all of the work of posting a menu (including
81 # unposting any other menu that might currently be posted). The "w"
82 # argument is the name of the menubutton for the menu to be posted.
83 # Note: if $w is disabled then the procedure does nothing.
84
85 proc tk_mbPost {w} {
86 global tk_priv
87 if {[lindex [$w config -state] 4] == "disabled"} {
88 return
89 }
90 set screen [winfo screen $w]
91 if {![info exists tk_priv(posted@$screen)]} {
92 set tk_priv(posted@$screen) {}
93 }
94 if {![info exists tk_priv(focus@$screen)]} {
95 set tk_priv(focus@$screen) {}
96 }
97 set cur $tk_priv(posted@$screen)
98 if {$cur == $w} {
99 return
100 }
101 if {$cur != ""} {tk_mbUnpost $w}
102 set tk_priv(relief@$screen) [lindex [$w config -relief] 4]
103 $w config -relief raised
104 set tk_priv(cursor@$screen) [lindex [$w config -cursor] 4]
105 $w config -cursor arrow
106 $w post
107 catch {grab -global $w}
108 set tk_priv(posted@$screen) $w
109 if {$tk_priv(focus@$screen) == ""} {
110 set tk_priv(focus@$screen) [focus -query $w]
111 }
112 set menu [lindex [$w config -menu] 4]
113 focus $menu
114 }
115
116 # The procedure below does all the work of unposting the menubutton that's
117 # currently posted. It takes no arguments.
118
119 proc tk_mbUnpost {w} {
120 global tk_priv
121 set screen [winfo screen $w]
122 if {![info exists tk_priv(posted@$screen)]} {
123 set tk_priv(posted@$screen) {}
124 }
125 if {![info exists tk_priv(focus@$screen)]} {
126 set tk_priv(focus@$screen) {}
127 }
128 set mb $tk_priv(posted@$screen)
129 if {$mb != ""} {
130 $mb config -relief $tk_priv(relief@$screen)
131 $mb config -cursor $tk_priv(cursor@$screen)
132 $mb unpost
133 catch {grab -off $mb}
134 set menu [lindex [$mb config -menu] 4]
135 focus $tk_priv(focus@$screen)
136 set tk_priv(focus@$screen) ""
137 set tk_priv(posted@$screen) {}
138 }
139 }
140
141 # The procedure below is invoked to implement keyboard traversal to
142 # a menu button. It takes two arguments: the name of a window where
143 # a keystroke originated, and the ascii character that was typed.
144 # This procedure finds a menu bar by looking upward for a top-level
145 # window, then looking for a window underneath that named "menu".
146 # Then it searches through all the subwindows of "menu" for a menubutton
147 # with an underlined character matching char. If one is found, it
148 # posts that menu.
149
150 proc tk_traverseToMenu {w char} {
151 if {$char == ""} {
152 return
153 }
154 set char [string tolower $char]
155
156 foreach mb [tk_getMenuButtons $w] {
157 if {[winfo class $mb] == "Menubutton"} {
158 set char2 [string index [lindex [$mb config -text] 4] \
159 [lindex [$mb config -underline] 4]]
160 if {[string compare $char [string tolower $char2]] == 0} {
161 tk_mbPost $mb
162 [lindex [$mb config -menu] 4] activate 0
163 return
164 }
165 }
166 }
167 }
168
169 # The procedure below is used to implement keyboard traversal within
170 # the posted menu. It takes two arguments: the name of the menu to
171 # be traversed within, and an ASCII character. It searches for an
172 # entry in the menu that has that character underlined. If such an
173 # entry is found, it is invoked and the menu is unposted.
174
175 proc tk_traverseWithinMenu {w char} {
176 if {$char == ""} {
177 return
178 }
179 set char [string tolower $char]
180 set last [$w index last]
181 for {set i 0} {$i <= $last} {incr i} {
182 if [catch {set char2 [string index \
183 [lindex [$w entryconfig $i -label] 4] \
184 [lindex [$w entryconfig $i -underline] 4]]}] {
185 continue
186 }
187 if {[string compare $char [string tolower $char2]] == 0} {
188 tk_mbUnpost $w
189 $w invoke $i
190 return
191 }
192 }
193 }
194
195 # The procedure below takes a single argument, which is the name of
196 # a window. It returns a list containing path names for all of the
197 # menu buttons associated with that window's top-level window, or an
198 # empty list if there are none.
199
200 proc tk_getMenuButtons {w} {
201 global tk_priv
202 set top [winfo toplevel $w]
203 if [catch {set buttons [set tk_priv(menusFor$top)]}] {
204 return ""
205 }
206 return $buttons
207 }
208
209 # The procedure below is used to traverse to the next or previous
210 # menu in a menu bar. It takes one argument, which is a count of
211 # how many menu buttons forward or backward (if negative) to move.
212 # If there is no posted menu then this procedure has no effect.
213
214 proc tk_nextMenu {w count} {
215 global tk_priv
216 set screen [winfo screen $w]
217 if {![info exists tk_priv(posted@$screen)]} {
218 set tk_priv(posted@$screen) {}
219 }
220 if {$tk_priv(posted@$screen) == ""} {
221 return
222 }
223 set buttons [tk_getMenuButtons $tk_priv(posted@$screen)]
224 set length [llength $buttons]
225 for {set i 0} 1 {incr i} {
226 if {$i >= $length} {
227 return
228 }
229 if {[lindex $buttons $i] == $tk_priv(posted@$screen)} {
230 break
231 }
232 }
233 incr i $count
234 while 1 {
235 while {$i < 0} {
236 incr i $length
237 }
238 while {$i >= $length} {
239 incr i -$length
240 }
241 set mb [lindex $buttons $i]
242 if {[lindex [$mb configure -state] 4] != "disabled"} {
243 break
244 }
245 incr i $count
246 }
247 tk_mbUnpost $w
248 tk_mbPost $mb
249 [lindex [$mb config -menu] 4] activate 0
250 }
251
252 # The procedure below is used to traverse to the next or previous entry
253 # in the posted menu. It takes one argument, which is 1 to go to the
254 # next entry or -1 to go to the previous entry. Disabled entries are
255 # skipped in this process.
256
257 proc tk_nextMenuEntry {w count} {
258 global tk_priv
259 set screen [winfo screen $w]
260 if {![info exists tk_priv(posted@$screen)]} {
261 set tk_priv(posted@$screen) {}
262 }
263 if {$tk_priv(posted@$screen) == ""} {
264 return
265 }
266 set menu [lindex [$tk_priv(posted@$screen) config -menu] 4]
267 set length [expr [$menu index last]+1]
268 set i [$menu index active]
269 if {$i == "none"} {
270 set i 0
271 } else {
272 incr i $count
273 }
274 while 1 {
275 while {$i < 0} {
276 incr i $length
277 }
278 while {$i >= $length} {
279 incr i -$length
280 }
281 if {[catch {$menu entryconfigure $i -state} state] == 0} {
282 if {[lindex $state 4] != "disabled"} {
283 break
284 }
285 }
286 incr i $count
287 }
288 $menu activate $i
289 }
290
291 # The procedure below invokes the active entry in the posted menu,
292 # if there is one. Otherwise it does nothing.
293
294 proc tk_invokeMenu {w} {
295 set i [$w index active]
296 if {$i != "none"} {
297 tk_mbUnpost $w
298 update idletasks
299 $w invoke $i
300 }
301 }
302
303 # The procedure below is invoked to keyboard-traverse to the first
304 # menu for a given source window. The source window is passed as
305 # parameter.
306
307 proc tk_firstMenu {w} {
308 set mb [lindex [tk_getMenuButtons $w] 0]
309 if {$mb != ""} {
310 tk_mbPost $mb
311 [lindex [$mb config -menu] 4] activate 0
312 }
313 }
314
315 # The procedure below is invoked when a button-1-down event is
316 # received by a menu button. If the mouse is in the menu button
317 # then it posts the button's menu. If the mouse isn't in the
318 # button's menu, then it deactivates any active entry in the menu.
319 # Remember, event-sharing can cause this procedure to be invoked
320 # for two different menu buttons on the same event.
321
322 proc tk_mbButtonDown {w x y} {
323 global tk_priv
324 set screen [winfo screen $w]
325 if {![info exists tk_priv(inMenuButton@$screen)]} {
326 set tk_priv(inMenuButton@$screen) {}
327 }
328 if {![info exists tk_priv(posted@$screen)]} {
329 set tk_priv(posted@$screen) {}
330 }
331 if {[lindex [$w config -state] 4] == "disabled"} {
332 return
333 }
334 if {$tk_priv(inMenuButton@$screen) == $w} {
335 tk_mbPost $w
336 }
337 if {$tk_priv(posted@$screen) != ""} then {
338 set menu [lindex [$tk_priv(posted@$screen) config -menu] 4]
339 if {![info exists tk_priv(window@$screen)]} {
340 set tk_priv(window@$screen) {}
341 }
342 if {$tk_priv(window@$screen) != $menu} {
343 $menu activate none
344 }
345 }
346 }
347
348 proc tk_mbButtonUp {w x y} {
349 global tk_priv
350 set screen [winfo screen $w]
351 if {![info exists tk_priv(inMenuButton@$screen)]} {
352 set tk_priv(inMenuButton@$screen) {}
353 }
354 if {![info exists tk_priv(posted@$screen)]} {
355 set tk_priv(posted@$screen) {}
356 }
357 if {($tk_priv(inMenuButton@$screen) != "") &&
358 ($tk_priv(posted@$screen) != "")} {
359 [lindex [$tk_priv(posted@$screen) config -menu] 4] activate 0
360 } else {
361 tk_mbUnpost $w
362 }
363 }
364
365 proc tk_mbButtonEnter {w m} {
366 global tk_priv
367 set screen [winfo screen $w]
368 set tk_priv(inMenuButton@$screen) $w
369 if {[lindex [$w config -state] 4] != "disabled"} {
370 $w config -state active
371 }
372 }
373
374 proc tk_mbButtonLeave {w} {
375 global tk_priv
376 set screen [winfo screen $w]
377 set tk_priv(inMenuButton@$screen) {}
378 if {[lindex [$w config -state] 4] != "disabled"} {
379 $w config -state normal
380 }
381 }
382
383 # In the binding below, it's important to ignore grab-related entries
384 # and exits because they lag reality and can cause menus to chase
385 # their own tail, repeatedly posting and unposting.
386
387 proc tk_mbButton1Enter {w m} {
388 global tk_priv
389 set screen [winfo screen $w]
390 set tk_priv(inMenuButton@$screen) $w
391 if {([lindex [$w config -state] 4] != "disabled")
392 && ("$m" != "NotifyGrab") && ("$m" != "NotifyUngrab")} {
393 $w config -state active
394 tk_mbPost $w
395 }
396 }
397
398
399 proc tk_mbButton2Down {w x y} {
400 global tk_priv
401 set screen [winfo screen $w]
402 if {![info exists tk_priv(inMenuButton@$screen)]} {
403 set tk_priv(inMenuButton@$screen) {}
404 }
405 if {![info exists tk_priv(posted@$screen)]} {
406 set tk_priv(posted@$screen) {}
407 }
408 if {($tk_priv(posted@$screen) == "")
409 && ([lindex [$w config -state] 4] != "disabled")} {
410 set tk_priv(dragging@$screen) $w
411 [lindex [$w config -menu] 4] post $x $y
412 }
413 }
414
415
416 proc tk_mbButton2Motion {w x y} {
417 global tk_priv
418 set screen [winfo screen $w]
419 if {![info exists tk_priv(dragging@$screen)]} {
420 set tk_priv(dragging@$screen) {}
421 }
422 if {$tk_priv(dragging@$screen) != ""} {
423 [lindex [$tk_priv(dragging@$screen) config -menu] 4] post $x $y
424 }
425 }
426
427 proc tk_mbButton2Up {w x y} {
428 global tk_priv
429 set screen [winfo screen $w]
430 set tk_priv(dragging@$screen) ""
431 }
432
433
434 proc tk_menuEnter {w y} {
435 global tk_priv
436 set screen [winfo screen $w]
437 set tk_priv(window@$screen) $w
438 $w activate @$y
439 }
440
441 proc tk_menuLeave {w} {
442 global tk_priv
443 set screen [winfo screen $w]
444 set tk_priv(window@$screen) {}
445 $w activate none
446 }
447
448 proc tk_menuMotion {w y} {
449 global tk_priv
450 set screen [winfo screen $w]
451 if {![info exists tk_priv(window@$screen)]} {
452 set tk_priv(window@$screen) {}
453 }
454 if {$tk_priv(window@$screen) != ""} {
455 $w activate @$y
456 }
457 }
458
459 proc tk_menuUp {w y} {
460 tk_menuMotion $w $y
461 tk_invokeMenu $w
462 }
463
464 proc tk_menu2Down {w x y} {
465 global tk_priv
466 set screen [winfo screen $w]
467 set tk_priv(x@$screen) $x
468 set tk_priv(y@$screen) $y
469 }
470
471 proc tk_menu2Motion {w x y} {
472 global tk_priv
473 set screen [winfo screen $w]
474 if {$tk_priv(posted@$screen) == ""} {
475 $w post [expr $x-$tk_priv(x@$screen)] [expr $y-$tk_priv(y@$screen)]
476 }
477 }
478
Impressum, Datenschutz