![[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 / src / tk / library|
Return to menu.tcl CVS log | Up to [Micropolis - Activity] / micropolis / src / tk / library |
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: 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.