source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/src/vrip/lib/tk/menu.tcl @ 37

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

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