source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/lib/linux/tk8.4/menu.tcl @ 37

Last change on this file since 37 was 37, checked in by (none), 14 years ago

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