![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to menu.tcl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / res|
Return to menu.tcl CVS log | Up to [Micropolis - Activity] / micropolis / res |
1.1 root 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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.