]> git.zerfleddert.de Git - micropolis/blame_incremental - res/menu.tcl
src/tk/makefile: Micropolis build fixes for recent macOS
[micropolis] / res / 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
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
50proc 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
73proc 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
85proc 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
119proc 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
150proc 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
175proc 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
200proc 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
214proc 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
257proc 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
294proc 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
307proc 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
322proc 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
348proc 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
365proc 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
374proc 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
387proc 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
399proc 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
416proc 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
427proc tk_mbButton2Up {w x y} {
428 global tk_priv
429 set screen [winfo screen $w]
430 set tk_priv(dragging@$screen) ""
431}
432
433
434proc 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
441proc 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
448proc 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
459proc tk_menuUp {w y} {
460 tk_menuMotion $w $y
461 tk_invokeMenu $w
462}
463
464proc 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
471proc 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