1# menu.tcl --
2#
3# This file defines the default bindings for Tk menus and menubuttons.
4# It also implements keyboard traversal of menus and implements a few
5# other utility procedures related to menus.
6#
7# RCS: @(#) $Id: menu.tcl,v 1.18.2.5 2007/11/09 06:26:54 das Exp $
8#
9# Copyright (c) 1992-1994 The Regents of the University of California.
10# Copyright (c) 1994-1997 Sun Microsystems, Inc.
11# Copyright (c) 1998-1999 by Scriptics Corporation.
12# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
13#
14# See the file "license.terms" for information on usage and redistribution
15# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16#
17
18#-------------------------------------------------------------------------
19# Elements of tk::Priv that are used in this file:
20#
21# cursor -		Saves the -cursor option for the posted menubutton.
22# focus -		Saves the focus during a menu selection operation.
23#			Focus gets restored here when the menu is unposted.
24# grabGlobal -		Used in conjunction with tk::Priv(oldGrab):  if
25#			tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal)
26#			contains either an empty string or "-global" to
27#			indicate whether the old grab was a local one or
28#			a global one.
29# inMenubutton -	The name of the menubutton widget containing
30#			the mouse, or an empty string if the mouse is
31#			not over any menubutton.
32# menuBar -		The name of the menubar that is the root
33#			of the cascade hierarchy which is currently
34#			posted. This is null when there is no menu currently
35#			being pulled down from a menu bar.
36# oldGrab -		Window that had the grab before a menu was posted.
37#			Used to restore the grab state after the menu
38#			is unposted.  Empty string means there was no
39#			grab previously set.
40# popup -		If a menu has been popped up via tk_popup, this
41#			gives the name of the menu.  Otherwise this
42#			value is empty.
43# postedMb -		Name of the menubutton whose menu is currently
44#			posted, or an empty string if nothing is posted
45#			A grab is set on this widget.
46# relief -		Used to save the original relief of the current
47#			menubutton.
48# window -		When the mouse is over a menu, this holds the
49#			name of the menu;  it's cleared when the mouse
50#			leaves the menu.
51# tearoff -		Whether the last menu posted was a tearoff or not.
52#			This is true always for unix, for tearoffs for Mac
53#			and Windows.
54# activeMenu -		This is the last active menu for use
55#			with the <<MenuSelect>> virtual event.
56# activeItem -		This is the last active menu item for
57#			use with the <<MenuSelect>> virtual event.
58#-------------------------------------------------------------------------
59
60#-------------------------------------------------------------------------
61# Overall note:
62# This file is tricky because there are five different ways that menus
63# can be used:
64#
65# 1. As a pulldown from a menubutton. In this style, the variable
66#    tk::Priv(postedMb) identifies the posted menubutton.
67# 2. As a torn-off menu copied from some other menu.  In this style
68#    tk::Priv(postedMb) is empty, and menu's type is "tearoff".
69# 3. As an option menu, triggered from an option menubutton.  In this
70#    style tk::Priv(postedMb) identifies the posted menubutton.
71# 4. As a popup menu.  In this style tk::Priv(postedMb) is empty and
72#    the top-level menu's type is "normal".
73# 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has
74#    the owning menubar, and the menu itself is of type "normal".
75#
76# The various binding procedures use the  state described above to
77# distinguish the various cases and take different actions in each
78# case.
79#-------------------------------------------------------------------------
80
81#-------------------------------------------------------------------------
82# The code below creates the default class bindings for menus
83# and menubuttons.
84#-------------------------------------------------------------------------
85
86bind Menubutton <FocusIn> {}
87bind Menubutton <Enter> {
88    tk::MbEnter %W
89}
90bind Menubutton <Leave> {
91    tk::MbLeave %W
92}
93bind Menubutton <1> {
94    if {$tk::Priv(inMenubutton) ne ""} {
95	tk::MbPost $tk::Priv(inMenubutton) %X %Y
96    }
97}
98bind Menubutton <Motion> {
99    tk::MbMotion %W up %X %Y
100}
101bind Menubutton <B1-Motion> {
102    tk::MbMotion %W down %X %Y
103}
104bind Menubutton <ButtonRelease-1> {
105    tk::MbButtonUp %W
106}
107bind Menubutton <space> {
108    tk::MbPost %W
109    tk::MenuFirstEntry [%W cget -menu]
110}
111
112# Must set focus when mouse enters a menu, in order to allow
113# mixed-mode processing using both the mouse and the keyboard.
114# Don't set the focus if the event comes from a grab release,
115# though:  such an event can happen after as part of unposting
116# a cascaded chain of menus, after the focus has already been
117# restored to wherever it was before menu selection started.
118
119bind Menu <FocusIn> {}
120
121bind Menu <Enter> {
122    set tk::Priv(window) %W
123    if {[%W cget -type] eq "tearoff"} {
124	if {"%m" ne "NotifyUngrab"} {
125	    if {[tk windowingsystem] eq "x11"} {
126		tk_menuSetFocus %W
127	    }
128	}
129    }
130    tk::MenuMotion %W %x %y %s
131}
132
133bind Menu <Leave> {
134    tk::MenuLeave %W %X %Y %s
135}
136bind Menu <Motion> {
137    tk::MenuMotion %W %x %y %s
138}
139bind Menu <ButtonPress> {
140    tk::MenuButtonDown %W
141}
142bind Menu <ButtonRelease> {
143   tk::MenuInvoke %W 1
144}
145bind Menu <space> {
146    tk::MenuInvoke %W 0
147}
148bind Menu <Return> {
149    tk::MenuInvoke %W 0
150}
151bind Menu <Escape> {
152    tk::MenuEscape %W
153}
154bind Menu <Left> {
155    tk::MenuLeftArrow %W
156}
157bind Menu <Right> {
158    tk::MenuRightArrow %W
159}
160bind Menu <Up> {
161    tk::MenuUpArrow %W
162}
163bind Menu <Down> {
164    tk::MenuDownArrow %W
165}
166bind Menu <KeyPress> {
167    tk::TraverseWithinMenu %W %A
168}
169
170# The following bindings apply to all windows, and are used to
171# implement keyboard menu traversal.
172
173if {[tk windowingsystem] eq "x11"} {
174    bind all <Alt-KeyPress> {
175	tk::TraverseToMenu %W %A
176    }
177
178    bind all <F10> {
179	tk::FirstMenu %W
180    }
181} else {
182    bind Menubutton <Alt-KeyPress> {
183	tk::TraverseToMenu %W %A
184    }
185
186    bind Menubutton <F10> {
187	tk::FirstMenu %W
188    }
189}
190
191# ::tk::MbEnter --
192# This procedure is invoked when the mouse enters a menubutton
193# widget.  It activates the widget unless it is disabled.  Note:
194# this procedure is only invoked when mouse button 1 is *not* down.
195# The procedure ::tk::MbB1Enter is invoked if the button is down.
196#
197# Arguments:
198# w -			The  name of the widget.
199
200proc ::tk::MbEnter w {
201    variable ::tk::Priv
202
203    if {$Priv(inMenubutton) ne ""} {
204	MbLeave $Priv(inMenubutton)
205    }
206    set Priv(inMenubutton) $w
207    if {[$w cget -state] ne "disabled" && [tk windowingsystem] ne "aqua"} {
208	$w configure -state active
209    }
210}
211
212# ::tk::MbLeave --
213# This procedure is invoked when the mouse leaves a menubutton widget.
214# It de-activates the widget, if the widget still exists.
215#
216# Arguments:
217# w -			The  name of the widget.
218
219proc ::tk::MbLeave w {
220    variable ::tk::Priv
221
222    set Priv(inMenubutton) {}
223    if {![winfo exists $w]} {
224	return
225    }
226    if {[$w cget -state] eq "active" && [tk windowingsystem] ne "aqua"} {
227	$w configure -state normal
228    }
229}
230
231# ::tk::MbPost --
232# Given a menubutton, this procedure does all the work of posting
233# its associated menu and unposting any other menu that is currently
234# posted.
235#
236# Arguments:
237# w -			The name of the menubutton widget whose menu
238#			is to be posted.
239# x, y -		Root coordinates of cursor, used for positioning
240#			option menus.  If not specified, then the center
241#			of the menubutton is used for an option menu.
242
243proc ::tk::MbPost {w {x {}} {y {}}} {
244    global errorInfo
245    variable ::tk::Priv
246    global tcl_platform
247
248    if {[$w cget -state] eq "disabled" || $w eq $Priv(postedMb)} {
249	return
250    }
251    set menu [$w cget -menu]
252    if {$menu eq ""} {
253	return
254    }
255    set tearoff [expr {[tk windowingsystem] eq "x11" \
256	    || [$menu cget -type] eq "tearoff"}]
257    if {[string first $w $menu] != 0} {
258	error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
259    }
260    set cur $Priv(postedMb)
261    if {$cur ne ""} {
262	MenuUnpost {}
263    }
264    set Priv(cursor) [$w cget -cursor]
265    $w configure -cursor arrow
266    if {[tk windowingsystem] ne "aqua"} {
267	set Priv(relief) [$w cget -relief]
268	$w configure -relief raised
269    } else {
270	$w configure -state active
271    }
272
273    set Priv(postedMb) $w
274    set Priv(focus) [focus]
275    $menu activate none
276    GenerateMenuSelect $menu
277
278    # If this looks like an option menubutton then post the menu so
279    # that the current entry is on top of the mouse.  Otherwise post
280    # the menu just below the menubutton, as for a pull-down.
281
282    update idletasks
283    if {[catch {
284	switch [$w cget -direction] {
285    	    above {
286    	    	set x [winfo rootx $w]
287    	    	set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
288		# if we go offscreen to the top, show as 'below'
289		if {$y < 0} {
290		    set y [expr {[winfo rooty $w] + [winfo height $w]}]
291		}
292		PostOverPoint $menu $x $y
293    	    }
294    	    below {
295    	    	set x [winfo rootx $w]
296    	    	set y [expr {[winfo rooty $w] + [winfo height $w]}]
297		# if we go offscreen to the bottom, show as 'above'
298		set mh [winfo reqheight $menu]
299		if {($y + $mh) > [winfo screenheight $w]} {
300		    set y [expr {[winfo rooty $w] - $mh}]
301		}
302		PostOverPoint $menu $x $y
303    	    }
304    	    left {
305    	    	set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
306    	    	set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
307    	    	set entry [MenuFindName $menu [$w cget -text]]
308    	    	if {[$w cget -indicatoron]} {
309		    if {$entry == [$menu index last]} {
310		    	incr y [expr {-([$menu yposition $entry] \
311			    	+ [winfo reqheight $menu])/2}]
312		    } else {
313		    	incr y [expr {-([$menu yposition $entry] \
314			        + [$menu yposition [expr {$entry+1}]])/2}]
315		    }
316    	    	}
317		PostOverPoint $menu $x $y
318		if {$entry ne "" \
319			&& [$menu entrycget $entry -state] ne "disabled"} {
320    	    	    $menu activate $entry
321		    GenerateMenuSelect $menu
322    	    	}
323    	    }
324    	    right {
325    	    	set x [expr {[winfo rootx $w] + [winfo width $w]}]
326    	    	set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
327    	    	set entry [MenuFindName $menu [$w cget -text]]
328    	    	if {[$w cget -indicatoron]} {
329		    if {$entry == [$menu index last]} {
330		    	incr y [expr {-([$menu yposition $entry] \
331			    	+ [winfo reqheight $menu])/2}]
332		    } else {
333		    	incr y [expr {-([$menu yposition $entry] \
334			        + [$menu yposition [expr {$entry+1}]])/2}]
335		    }
336    	    	}
337		PostOverPoint $menu $x $y
338		if {$entry ne "" \
339			&& [$menu entrycget $entry -state] ne "disabled"} {
340    	    	    $menu activate $entry
341		    GenerateMenuSelect $menu
342    	    	}
343    	    }
344    	    default {
345    	    	if {[$w cget -indicatoron]} {
346		    if {$y eq ""} {
347			set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
348			set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
349	    	    }
350	            PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]]
351		} else {
352		    PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
353    	    	}
354    	    }
355	}
356    } msg]} {
357	# Error posting menu (e.g. bogus -postcommand). Unpost it and
358	# reflect the error.
359
360	set savedInfo $errorInfo
361	MenuUnpost {}
362	error $msg $savedInfo
363
364    }
365
366    set Priv(tearoff) $tearoff
367    if {$tearoff != 0} {
368    	focus $menu
369	if {[winfo viewable $w]} {
370	    SaveGrabInfo $w
371	    grab -global $w
372	}
373    }
374}
375
376# ::tk::MenuUnpost --
377# This procedure unposts a given menu, plus all of its ancestors up
378# to (and including) a menubutton, if any.  It also restores various
379# values to what they were before the menu was posted, and releases
380# a grab if there's a menubutton involved.  Special notes:
381# 1. It's important to unpost all menus before releasing the grab, so
382#    that any Enter-Leave events (e.g. from menu back to main
383#    application) have mode NotifyGrab.
384# 2. Be sure to enclose various groups of commands in "catch" so that
385#    the procedure will complete even if the menubutton or the menu
386#    or the grab window has been deleted.
387#
388# Arguments:
389# menu -		Name of a menu to unpost.  Ignored if there
390#			is a posted menubutton.
391
392proc ::tk::MenuUnpost menu {
393    global tcl_platform
394    variable ::tk::Priv
395    set mb $Priv(postedMb)
396
397    # Restore focus right away (otherwise X will take focus away when
398    # the menu is unmapped and under some window managers (e.g. olvwm)
399    # we'll lose the focus completely).
400
401    catch {focus $Priv(focus)}
402    set Priv(focus) ""
403
404    # Unpost menu(s) and restore some stuff that's dependent on
405    # what was posted.
406
407    catch {
408	if {$mb ne ""} {
409	    set menu [$mb cget -menu]
410	    $menu unpost
411	    set Priv(postedMb) {}
412	    $mb configure -cursor $Priv(cursor)
413	    if {[tk windowingsystem] ne "aqua"} {
414		$mb configure -relief $Priv(relief)
415	    } else {
416		$mb configure -state normal
417	    }
418	} elseif {$Priv(popup) ne ""} {
419	    $Priv(popup) unpost
420	    set Priv(popup) {}
421	} elseif {[$menu cget -type] ne "menubar" && [$menu cget -type] ne "tearoff"} {
422	    # We're in a cascaded sub-menu from a torn-off menu or popup.
423	    # Unpost all the menus up to the toplevel one (but not
424	    # including the top-level torn-off one) and deactivate the
425	    # top-level torn off menu if there is one.
426
427	    while {1} {
428		set parent [winfo parent $menu]
429		if {[winfo class $parent] ne "Menu" || ![winfo ismapped $parent]} {
430		    break
431		}
432		$parent activate none
433		$parent postcascade none
434		GenerateMenuSelect $parent
435		set type [$parent cget -type]
436		if {$type eq "menubar" || $type eq "tearoff"} {
437		    break
438		}
439		set menu $parent
440	    }
441	    if {[$menu cget -type] ne "menubar"} {
442		$menu unpost
443	    }
444	}
445    }
446
447    if {($Priv(tearoff) != 0) || $Priv(menuBar) ne ""} {
448    	# Release grab, if any, and restore the previous grab, if there
449    	# was one.
450	if {$menu ne ""} {
451	    set grab [grab current $menu]
452	    if {$grab ne ""} {
453		grab release $grab
454	    }
455	}
456	RestoreOldGrab
457	if {$Priv(menuBar) ne ""} {
458	    $Priv(menuBar) configure -cursor $Priv(cursor)
459	    set Priv(menuBar) {}
460	}
461	if {[tk windowingsystem] ne "x11"} {
462	    set Priv(tearoff) 0
463	}
464    }
465}
466
467# ::tk::MbMotion --
468# This procedure handles mouse motion events inside menubuttons, and
469# also outside menubuttons when a menubutton has a grab (e.g. when a
470# menu selection operation is in progress).
471#
472# Arguments:
473# w -			The name of the menubutton widget.
474# upDown - 		"down" means button 1 is pressed, "up" means
475#			it isn't.
476# rootx, rooty -	Coordinates of mouse, in (virtual?) root window.
477
478proc ::tk::MbMotion {w upDown rootx rooty} {
479    variable ::tk::Priv
480
481    if {$Priv(inMenubutton) eq $w} {
482	return
483    }
484    set new [winfo containing $rootx $rooty]
485    if {$new ne $Priv(inMenubutton) \
486	    && ($new eq "" || [winfo toplevel $new] eq [winfo toplevel $w])} {
487	if {$Priv(inMenubutton) ne ""} {
488	    MbLeave $Priv(inMenubutton)
489	}
490	if {$new ne "" \
491		&& [winfo class $new] eq "Menubutton" \
492		&& ([$new cget -indicatoron] == 0) \
493		&& ([$w cget -indicatoron] == 0)} {
494	    if {$upDown eq "down"} {
495		MbPost $new $rootx $rooty
496	    } else {
497		MbEnter $new
498	    }
499	}
500    }
501}
502
503# ::tk::MbButtonUp --
504# This procedure is invoked to handle button 1 releases for menubuttons.
505# If the release happens inside the menubutton then leave its menu
506# posted with element 0 activated.  Otherwise, unpost the menu.
507#
508# Arguments:
509# w -			The name of the menubutton widget.
510
511proc ::tk::MbButtonUp w {
512    variable ::tk::Priv
513    global tcl_platform
514
515    set menu [$w cget -menu]
516    set tearoff [expr {[tk windowingsystem] eq "x11" || \
517	    ($menu ne "" && [$menu cget -type] eq "tearoff")}]
518    if {($tearoff != 0) && $Priv(postedMb) eq $w \
519	    && $Priv(inMenubutton) eq $w} {
520	MenuFirstEntry [$Priv(postedMb) cget -menu]
521    } else {
522	MenuUnpost {}
523    }
524}
525
526# ::tk::MenuMotion --
527# This procedure is called to handle mouse motion events for menus.
528# It does two things.  First, it resets the active element in the
529# menu, if the mouse is over the menu.  Second, if a mouse button
530# is down, it posts and unposts cascade entries to match the mouse
531# position.
532#
533# Arguments:
534# menu -		The menu window.
535# x -			The x position of the mouse.
536# y -			The y position of the mouse.
537# state -		Modifier state (tells whether buttons are down).
538
539proc ::tk::MenuMotion {menu x y state} {
540    variable ::tk::Priv
541    if {$menu eq $Priv(window)} {
542	if {[$menu cget -type] eq "menubar"} {
543	    if {[info exists Priv(focus)] && $menu ne $Priv(focus)} {
544		$menu activate @$x,$y
545		GenerateMenuSelect $menu
546	    }
547	} else {
548	    $menu activate @$x,$y
549	    GenerateMenuSelect $menu
550	}
551    }
552    if {($state & 0x1f00) != 0} {
553	$menu postcascade active
554    }
555}
556
557# ::tk::MenuButtonDown --
558# Handles button presses in menus.  There are a couple of tricky things
559# here:
560# 1. Change the posted cascade entry (if any) to match the mouse position.
561# 2. If there is a posted menubutton, must grab to the menubutton;  this
562#    overrrides the implicit grab on button press, so that the menu
563#    button can track mouse motions over other menubuttons and change
564#    the posted menu.
565# 3. If there's no posted menubutton (e.g. because we're a torn-off menu
566#    or one of its descendants) must grab to the top-level menu so that
567#    we can track mouse motions across the entire menu hierarchy.
568#
569# Arguments:
570# menu -		The menu window.
571
572proc ::tk::MenuButtonDown menu {
573    variable ::tk::Priv
574    global tcl_platform
575
576    if {![winfo viewable $menu]} {
577        return
578    }
579    $menu postcascade active
580    if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} {
581	grab -global $Priv(postedMb)
582    } else {
583	while {[$menu cget -type] eq "normal" \
584		&& [winfo class [winfo parent $menu]] eq "Menu" \
585		&& [winfo ismapped [winfo parent $menu]]} {
586	    set menu [winfo parent $menu]
587	}
588
589	if {$Priv(menuBar) eq ""} {
590	    set Priv(menuBar) $menu
591	    set Priv(cursor) [$menu cget -cursor]
592	    $menu configure -cursor arrow
593        }
594
595	# Don't update grab information if the grab window isn't changing.
596	# Otherwise, we'll get an error when we unpost the menus and
597	# restore the grab, since the old grab window will not be viewable
598	# anymore.
599
600	if {$menu ne [grab current $menu]} {
601	    SaveGrabInfo $menu
602	}
603
604	# Must re-grab even if the grab window hasn't changed, in order
605	# to release the implicit grab from the button press.
606
607	if {[tk windowingsystem] eq "x11"} {
608	    grab -global $menu
609	}
610    }
611}
612
613# ::tk::MenuLeave --
614# This procedure is invoked to handle Leave events for a menu.  It
615# deactivates everything unless the active element is a cascade element
616# and the mouse is now over the submenu.
617#
618# Arguments:
619# menu -		The menu window.
620# rootx, rooty -	Root coordinates of mouse.
621# state -		Modifier state.
622
623proc ::tk::MenuLeave {menu rootx rooty state} {
624    variable ::tk::Priv
625    set Priv(window) {}
626    if {[$menu index active] eq "none"} {
627	return
628    }
629    if {[$menu type active] eq "cascade" \
630	    && [winfo containing $rootx $rooty] eq [$menu entrycget active -menu]} {
631	return
632    }
633    $menu activate none
634    GenerateMenuSelect $menu
635}
636
637# ::tk::MenuInvoke --
638# This procedure is invoked when button 1 is released over a menu.
639# It invokes the appropriate menu action and unposts the menu if
640# it came from a menubutton.
641#
642# Arguments:
643# w -			Name of the menu widget.
644# buttonRelease -	1 means this procedure is called because of
645#			a button release;  0 means because of keystroke.
646
647proc ::tk::MenuInvoke {w buttonRelease} {
648    variable ::tk::Priv
649
650    if {$buttonRelease && $Priv(window) eq ""} {
651	# Mouse was pressed over a menu without a menu button, then
652	# dragged off the menu (possibly with a cascade posted) and
653	# released.  Unpost everything and quit.
654
655	$w postcascade none
656	$w activate none
657	event generate $w <<MenuSelect>>
658	MenuUnpost $w
659	return
660    }
661    if {[$w type active] eq "cascade"} {
662	$w postcascade active
663	set menu [$w entrycget active -menu]
664	MenuFirstEntry $menu
665    } elseif {[$w type active] eq "tearoff"} {
666	::tk::TearOffMenu $w
667	MenuUnpost $w
668    } elseif {[$w cget -type] eq "menubar"} {
669	$w postcascade none
670	set active [$w index active]
671	set isCascade [string equal [$w type $active] "cascade"]
672
673	# Only de-activate the active item if it's a cascade; this prevents
674	# the annoying "activation flicker" you otherwise get with
675	# checkbuttons/commands/etc. on menubars
676
677	if { $isCascade } {
678	    $w activate none
679	    event generate $w <<MenuSelect>>
680	}
681
682	MenuUnpost $w
683
684	# If the active item is not a cascade, invoke it.  This enables
685	# the use of checkbuttons/commands/etc. on menubars (which is legal,
686	# but not recommended)
687
688	if { !$isCascade } {
689	    uplevel #0 [list $w invoke $active]
690	}
691    } else {
692	set active [$w index active]
693	if {$Priv(popup) eq "" || $active ne "none"} {
694	    MenuUnpost $w
695	}
696	uplevel #0 [list $w invoke active]
697    }
698}
699
700# ::tk::MenuEscape --
701# This procedure is invoked for the Cancel (or Escape) key.  It unposts
702# the given menu and, if it is the top-level menu for a menu button,
703# unposts the menu button as well.
704#
705# Arguments:
706# menu -		Name of the menu window.
707
708proc ::tk::MenuEscape menu {
709    set parent [winfo parent $menu]
710    if {[winfo class $parent] ne "Menu"} {
711	MenuUnpost $menu
712    } elseif {[$parent cget -type] eq "menubar"} {
713	MenuUnpost $menu
714	RestoreOldGrab
715    } else {
716	MenuNextMenu $menu left
717    }
718}
719
720# The following routines handle arrow keys. Arrow keys behave
721# differently depending on whether the menu is a menu bar or not.
722
723proc ::tk::MenuUpArrow {menu} {
724    if {[$menu cget -type] eq "menubar"} {
725	MenuNextMenu $menu left
726    } else {
727	MenuNextEntry $menu -1
728    }
729}
730
731proc ::tk::MenuDownArrow {menu} {
732    if {[$menu cget -type] eq "menubar"} {
733	MenuNextMenu $menu right
734    } else {
735	MenuNextEntry $menu 1
736    }
737}
738
739proc ::tk::MenuLeftArrow {menu} {
740    if {[$menu cget -type] eq "menubar"} {
741	MenuNextEntry $menu -1
742    } else {
743	MenuNextMenu $menu left
744    }
745}
746
747proc ::tk::MenuRightArrow {menu} {
748    if {[$menu cget -type] eq "menubar"} {
749	MenuNextEntry $menu 1
750    } else {
751	MenuNextMenu $menu right
752    }
753}
754
755# ::tk::MenuNextMenu --
756# This procedure is invoked to handle "left" and "right" traversal
757# motions in menus.  It traverses to the next menu in a menu bar,
758# or into or out of a cascaded menu.
759#
760# Arguments:
761# menu -		The menu that received the keyboard
762#			event.
763# direction -		Direction in which to move: "left" or "right"
764
765proc ::tk::MenuNextMenu {menu direction} {
766    variable ::tk::Priv
767
768    # First handle traversals into and out of cascaded menus.
769
770    if {$direction eq "right"} {
771	set count 1
772	set parent [winfo parent $menu]
773	set class [winfo class $parent]
774	if {[$menu type active] eq "cascade"} {
775	    $menu postcascade active
776	    set m2 [$menu entrycget active -menu]
777	    if {$m2 ne ""} {
778		MenuFirstEntry $m2
779	    }
780	    return
781	} else {
782	    set parent [winfo parent $menu]
783	    while {$parent ne "."} {
784		if {[winfo class $parent] eq "Menu" && [$parent cget -type] eq "menubar"} {
785		    tk_menuSetFocus $parent
786		    MenuNextEntry $parent 1
787		    return
788		}
789		set parent [winfo parent $parent]
790	    }
791	}
792    } else {
793	set count -1
794	set m2 [winfo parent $menu]
795	if {[winfo class $m2] eq "Menu"} {
796	    $menu activate none
797	    GenerateMenuSelect $menu
798	    tk_menuSetFocus $m2
799
800	    $m2 postcascade none
801
802	    if {[$m2 cget -type] ne "menubar"} {
803		return
804	    }
805	}
806    }
807
808    # Can't traverse into or out of a cascaded menu.  Go to the next
809    # or previous menubutton, if that makes sense.
810
811    set m2 [winfo parent $menu]
812    if {[winfo class $m2] eq "Menu"} {
813	if {[$m2 cget -type] eq "menubar"} {
814	    tk_menuSetFocus $m2
815	    MenuNextEntry $m2 -1
816	    return
817	}
818    }
819
820    set w $Priv(postedMb)
821    if {$w eq ""} {
822	return
823    }
824    set buttons [winfo children [winfo parent $w]]
825    set length [llength $buttons]
826    set i [expr {[lsearch -exact $buttons $w] + $count}]
827    while {1} {
828	while {$i < 0} {
829	    incr i $length
830	}
831	while {$i >= $length} {
832	    incr i -$length
833	}
834	set mb [lindex $buttons $i]
835	if {[winfo class $mb] eq "Menubutton" \
836		&& [$mb cget -state] ne "disabled" \
837		&& [$mb cget -menu] ne "" \
838		&& [[$mb cget -menu] index last] ne "none"} {
839	    break
840	}
841	if {$mb eq $w} {
842	    return
843	}
844	incr i $count
845    }
846    MbPost $mb
847    MenuFirstEntry [$mb cget -menu]
848}
849
850# ::tk::MenuNextEntry --
851# Activate the next higher or lower entry in the posted menu,
852# wrapping around at the ends.  Disabled entries are skipped.
853#
854# Arguments:
855# menu -			Menu window that received the keystroke.
856# count -			1 means go to the next lower entry,
857#				-1 means go to the next higher entry.
858
859proc ::tk::MenuNextEntry {menu count} {
860    if {[$menu index last] eq "none"} {
861	return
862    }
863    set length [expr {[$menu index last]+1}]
864    set quitAfter $length
865    set active [$menu index active]
866    if {$active eq "none"} {
867	set i 0
868    } else {
869	set i [expr {$active + $count}]
870    }
871    while {1} {
872	if {$quitAfter <= 0} {
873	    # We've tried every entry in the menu.  Either there are
874	    # none, or they're all disabled.  Just give up.
875
876	    return
877	}
878	while {$i < 0} {
879	    incr i $length
880	}
881	while {$i >= $length} {
882	    incr i -$length
883	}
884	if {[catch {$menu entrycget $i -state} state] == 0} {
885	    if {$state ne "disabled" && \
886		    ($i!=0 || [$menu cget -type] ne "tearoff" \
887		    || [$menu type 0] ne "tearoff")} {
888		break
889	    }
890	}
891	if {$i == $active} {
892	    return
893	}
894	incr i $count
895	incr quitAfter -1
896    }
897    $menu activate $i
898    GenerateMenuSelect $menu
899
900    if {[$menu type $i] eq "cascade" && [$menu cget -type] eq "menubar"} {
901	set cascade [$menu entrycget $i -menu]
902	if {$cascade ne ""} {
903	    # Here we auto-post a cascade.  This is necessary when
904	    # we traverse left/right in the menubar, but undesirable when
905	    # we traverse up/down in a menu.
906	    $menu postcascade $i
907	    MenuFirstEntry $cascade
908	}
909    }
910}
911
912# ::tk::MenuFind --
913# This procedure searches the entire window hierarchy under w for
914# a menubutton that isn't disabled and whose underlined character
915# is "char" or an entry in a menubar that isn't disabled and whose
916# underlined character is "char".
917# It returns the name of that window, if found, or an
918# empty string if no matching window was found.  If "char" is an
919# empty string then the procedure returns the name of the first
920# menubutton found that isn't disabled.
921#
922# Arguments:
923# w -				Name of window where key was typed.
924# char -			Underlined character to search for;
925#				may be either upper or lower case, and
926#				will match either upper or lower case.
927
928proc ::tk::MenuFind {w char} {
929    set char [string tolower $char]
930    set windowlist [winfo child $w]
931
932    foreach child $windowlist {
933	# Don't descend into other toplevels.
934        if {[winfo toplevel $w] ne [winfo toplevel $child]} {
935	    continue
936	}
937	if {[winfo class $child] eq "Menu" && [$child cget -type] eq "menubar"} {
938	    if {$char eq ""} {
939		return $child
940	    }
941	    set last [$child index last]
942	    for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
943		if {[$child type $i] eq "separator"} {
944		    continue
945		}
946		set char2 [string index [$child entrycget $i -label] \
947			[$child entrycget $i -underline]]
948		if {$char eq [string tolower $char2] || $char eq ""} {
949		    if {[$child entrycget $i -state] ne "disabled"} {
950			return $child
951		    }
952		}
953	    }
954	}
955    }
956
957    foreach child $windowlist {
958	# Don't descend into other toplevels.
959        if {[winfo toplevel $w] ne [winfo toplevel $child]} {
960	    continue
961	}
962	switch [winfo class $child] {
963	    Menubutton {
964		set char2 [string index [$child cget -text] \
965			[$child cget -underline]]
966		if {$char eq [string tolower $char2] || $char eq ""} {
967		    if {[$child cget -state] ne "disabled"} {
968			return $child
969		    }
970		}
971	    }
972
973	    default {
974		set match [MenuFind $child $char]
975		if {$match ne ""} {
976		    return $match
977		}
978	    }
979	}
980    }
981    return {}
982}
983
984# ::tk::TraverseToMenu --
985# This procedure implements keyboard traversal of menus.  Given an
986# ASCII character "char", it looks for a menubutton with that character
987# underlined.  If one is found, it posts the menubutton's menu
988#
989# Arguments:
990# w -				Window in which the key was typed (selects
991#				a toplevel window).
992# char -			Character that selects a menu.  The case
993#				is ignored.  If an empty string, nothing
994#				happens.
995
996proc ::tk::TraverseToMenu {w char} {
997    variable ::tk::Priv
998    if {$char eq ""} {
999	return
1000    }
1001    while {[winfo class $w] eq "Menu"} {
1002	if {[$w cget -type] eq "menubar"} {
1003	    break
1004	} elseif {$Priv(postedMb) eq ""} {
1005	    return
1006	}
1007	set w [winfo parent $w]
1008    }
1009    set w [MenuFind [winfo toplevel $w] $char]
1010    if {$w ne ""} {
1011	if {[winfo class $w] eq "Menu"} {
1012	    tk_menuSetFocus $w
1013	    set Priv(window) $w
1014	    SaveGrabInfo $w
1015	    grab -global $w
1016	    TraverseWithinMenu $w $char
1017	} else {
1018	    MbPost $w
1019	    MenuFirstEntry [$w cget -menu]
1020	}
1021    }
1022}
1023
1024# ::tk::FirstMenu --
1025# This procedure traverses to the first menubutton in the toplevel
1026# for a given window, and posts that menubutton's menu.
1027#
1028# Arguments:
1029# w -				Name of a window.  Selects which toplevel
1030#				to search for menubuttons.
1031
1032proc ::tk::FirstMenu w {
1033    variable ::tk::Priv
1034    set w [MenuFind [winfo toplevel $w] ""]
1035    if {$w ne ""} {
1036	if {[winfo class $w] eq "Menu"} {
1037	    tk_menuSetFocus $w
1038	    set Priv(window) $w
1039	    SaveGrabInfo $w
1040	    grab -global $w
1041	    MenuFirstEntry $w
1042	} else {
1043	    MbPost $w
1044	    MenuFirstEntry [$w cget -menu]
1045	}
1046    }
1047}
1048
1049# ::tk::TraverseWithinMenu
1050# This procedure implements keyboard traversal within a menu.  It
1051# searches for an entry in the menu that has "char" underlined.  If
1052# such an entry is found, it is invoked and the menu is unposted.
1053#
1054# Arguments:
1055# w -				The name of the menu widget.
1056# char -			The character to look for;  case is
1057#				ignored.  If the string is empty then
1058#				nothing happens.
1059
1060proc ::tk::TraverseWithinMenu {w char} {
1061    if {$char eq ""} {
1062	return
1063    }
1064    set char [string tolower $char]
1065    set last [$w index last]
1066    if {$last eq "none"} {
1067	return
1068    }
1069    for {set i 0} {$i <= $last} {incr i} {
1070	if {[catch {set char2 [string index \
1071		[$w entrycget $i -label] [$w entrycget $i -underline]]}]} {
1072	    continue
1073	}
1074	if {$char eq [string tolower $char2]} {
1075	    if {[$w type $i] eq "cascade"} {
1076		$w activate $i
1077		$w postcascade active
1078		event generate $w <<MenuSelect>>
1079		set m2 [$w entrycget $i -menu]
1080		if {$m2 ne ""} {
1081		    MenuFirstEntry $m2
1082		}
1083	    } else {
1084		MenuUnpost $w
1085		uplevel #0 [list $w invoke $i]
1086	    }
1087	    return
1088	}
1089    }
1090}
1091
1092# ::tk::MenuFirstEntry --
1093# Given a menu, this procedure finds the first entry that isn't
1094# disabled or a tear-off or separator, and activates that entry.
1095# However, if there is already an active entry in the menu (e.g.,
1096# because of a previous call to tk::PostOverPoint) then the active
1097# entry isn't changed.  This procedure also sets the input focus
1098# to the menu.
1099#
1100# Arguments:
1101# menu -		Name of the menu window (possibly empty).
1102
1103proc ::tk::MenuFirstEntry menu {
1104    if {$menu eq ""} {
1105	return
1106    }
1107    tk_menuSetFocus $menu
1108    if {[$menu index active] ne "none"} {
1109	return
1110    }
1111    set last [$menu index last]
1112    if {$last eq "none"} {
1113	return
1114    }
1115    for {set i 0} {$i <= $last} {incr i} {
1116	if {([catch {set state [$menu entrycget $i -state]}] == 0) \
1117		&& $state ne "disabled" \
1118		&& [$menu type $i] ne "tearoff"} {
1119	    $menu activate $i
1120	    GenerateMenuSelect $menu
1121	    # Only post the cascade if the current menu is a menubar;
1122	    # otherwise, if the first entry of the cascade is a cascade,
1123	    # we can get an annoying cascading effect resulting in a bunch of
1124	    # menus getting posted (bug 676)
1125	    if {[$menu type $i] eq "cascade" &&	[$menu cget -type] eq "menubar"} {
1126		set cascade [$menu entrycget $i -menu]
1127		if {$cascade ne ""} {
1128		    $menu postcascade $i
1129		    MenuFirstEntry $cascade
1130		}
1131	    }
1132	    return
1133	}
1134    }
1135}
1136
1137# ::tk::MenuFindName --
1138# Given a menu and a text string, return the index of the menu entry
1139# that displays the string as its label.  If there is no such entry,
1140# return an empty string.  This procedure is tricky because some names
1141# like "active" have a special meaning in menu commands, so we can't
1142# always use the "index" widget command.
1143#
1144# Arguments:
1145# menu -		Name of the menu widget.
1146# s -			String to look for.
1147
1148proc ::tk::MenuFindName {menu s} {
1149    set i ""
1150    if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
1151	catch {set i [$menu index $s]}
1152	return $i
1153    }
1154    set last [$menu index last]
1155    if {$last eq "none"} {
1156	return
1157    }
1158    for {set i 0} {$i <= $last} {incr i} {
1159	if {![catch {$menu entrycget $i -label} label]} {
1160	    if {$label eq $s} {
1161		return $i
1162	    }
1163	}
1164    }
1165    return ""
1166}
1167
1168# ::tk::PostOverPoint --
1169# This procedure posts a given menu such that a given entry in the
1170# menu is centered over a given point in the root window.  It also
1171# activates the given entry.
1172#
1173# Arguments:
1174# menu -		Menu to post.
1175# x, y -		Root coordinates of point.
1176# entry -		Index of entry within menu to center over (x,y).
1177#			If omitted or specified as {}, then the menu's
1178#			upper-left corner goes at (x,y).
1179
1180proc ::tk::PostOverPoint {menu x y {entry {}}}  {
1181    global tcl_platform
1182
1183    if {$entry ne ""} {
1184	if {$entry == [$menu index last]} {
1185	    incr y [expr {-([$menu yposition $entry] \
1186		    + [winfo reqheight $menu])/2}]
1187	} else {
1188	    incr y [expr {-([$menu yposition $entry] \
1189		    + [$menu yposition [expr {$entry+1}]])/2}]
1190	}
1191	incr x [expr {-[winfo reqwidth $menu]/2}]
1192    }
1193    if {$tcl_platform(platform) eq "windows"} {
1194	# We need to fix some problems with menu posting on Windows,
1195	# where, if the menu would overlap top or bottom of screen,
1196	# Windows puts it in the wrong place for us.  We must also
1197	# subtract an extra amount for half the height of the current
1198	# entry.  To be safe we subtract an extra 10.
1199	set yoffset [expr {[winfo screenheight $menu] \
1200		- $y - [winfo reqheight $menu] - 10}]
1201	if {$yoffset < 0} {
1202	    # The bottom of the menu is offscreen, so adjust upwards
1203	    incr y $yoffset
1204	    if {$y < 0} { set y 0 }
1205	}
1206	# If we're off the top of the screen (either because we were
1207	# originally or because we just adjusted too far upwards),
1208	# then make the menu popup on the top edge.
1209	if {$y < 0} {
1210	    set y 0
1211	}
1212    }
1213    $menu post $x $y
1214    if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
1215	$menu activate $entry
1216	GenerateMenuSelect $menu
1217    }
1218}
1219
1220# ::tk::SaveGrabInfo --
1221# Sets the variables tk::Priv(oldGrab) and tk::Priv(grabStatus) to record
1222# the state of any existing grab on the w's display.
1223#
1224# Arguments:
1225# w -			Name of a window;  used to select the display
1226#			whose grab information is to be recorded.
1227
1228proc tk::SaveGrabInfo w {
1229    variable ::tk::Priv
1230    set Priv(oldGrab) [grab current $w]
1231    if {$Priv(oldGrab) ne ""} {
1232	set Priv(grabStatus) [grab status $Priv(oldGrab)]
1233    }
1234}
1235
1236# ::tk::RestoreOldGrab --
1237# Restores the grab to what it was before TkSaveGrabInfo was called.
1238#
1239
1240proc ::tk::RestoreOldGrab {} {
1241    variable ::tk::Priv
1242
1243    if {$Priv(oldGrab) ne ""} {
1244    	# Be careful restoring the old grab, since it's window may not
1245	# be visible anymore.
1246
1247	catch {
1248          if {$Priv(grabStatus) eq "global"} {
1249		grab set -global $Priv(oldGrab)
1250	    } else {
1251		grab set $Priv(oldGrab)
1252	    }
1253	}
1254	set Priv(oldGrab) ""
1255    }
1256}
1257
1258proc ::tk_menuSetFocus {menu} {
1259    variable ::tk::Priv
1260    if {![info exists Priv(focus)] || $Priv(focus) eq ""} {
1261	set Priv(focus) [focus]
1262    }
1263    focus $menu
1264}
1265
1266proc ::tk::GenerateMenuSelect {menu} {
1267    variable ::tk::Priv
1268
1269    if {$Priv(activeMenu) eq $menu && $Priv(activeItem) eq [$menu index active]} {
1270	return
1271    }
1272
1273    set Priv(activeMenu) $menu
1274    set Priv(activeItem) [$menu index active]
1275    event generate $menu <<MenuSelect>>
1276}
1277
1278# ::tk_popup --
1279# This procedure pops up a menu and sets things up for traversing
1280# the menu and its submenus.
1281#
1282# Arguments:
1283# menu -		Name of the menu to be popped up.
1284# x, y -		Root coordinates at which to pop up the
1285#			menu.
1286# entry -		Index of a menu entry to center over (x,y).
1287#			If omitted or specified as {}, then menu's
1288#			upper-left corner goes at (x,y).
1289
1290proc ::tk_popup {menu x y {entry {}}} {
1291    variable ::tk::Priv
1292    global tcl_platform
1293    if {$Priv(popup) ne "" || $Priv(postedMb) ne ""} {
1294	tk::MenuUnpost {}
1295    }
1296    tk::PostOverPoint $menu $x $y $entry
1297    if {[tk windowingsystem] eq "x11" && [winfo viewable $menu]} {
1298        tk::SaveGrabInfo $menu
1299	grab -global $menu
1300	set Priv(popup) $menu
1301	tk_menuSetFocus $menu
1302    }
1303}
1304