URL https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tk/] [library/] [menu.tcl] - Blame information for rev 1765

Details | Compare with Previous | View Log

# menu.tcl --
#
# This file defines the default bindings for Tk menus and menubuttons.
# It also implements keyboard traversal of menus and implements a few
# other utility procedures related to menus.
#
# SCCS: @(#) menu.tcl 1.103 97/10/31 15:26:08
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
 
#-------------------------------------------------------------------------
# Elements of tkPriv that are used in this file:
#
# cursor -              Saves the -cursor option for the posted menubutton.
# focus -               Saves the focus during a menu selection operation.
#                       Focus gets restored here when the menu is unposted.
# grabGlobal -          Used in conjunction with tkPriv(oldGrab):  if
#                       tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal)
#                       contains either an empty string or "-global" to
#                       indicate whether the old grab was a local one or
#                       a global one.
# inMenubutton -        The name of the menubutton widget containing
#                       the mouse, or an empty string if the mouse is
#                       not over any menubutton.
# menuBar -             The name of the menubar that is the root
#                       of the cascade hierarchy which is currently
#                       posted. This is null when there is no menu currently
#                       being pulled down from a menu bar.
# oldGrab -             Window that had the grab before a menu was posted.
#                       Used to restore the grab state after the menu
#                       is unposted.  Empty string means there was no
#                       grab previously set.
# popup -               If a menu has been popped up via tk_popup, this
#                       gives the name of the menu.  Otherwise this
#                       value is empty.
# postedMb -            Name of the menubutton whose menu is currently
#                       posted, or an empty string if nothing is posted
#                       A grab is set on this widget.
# relief -              Used to save the original relief of the current
#                       menubutton.
# window -              When the mouse is over a menu, this holds the
#                       name of the menu;  it's cleared when the mouse
#                       leaves the menu.
# tearoff -             Whether the last menu posted was a tearoff or not.
#                       This is true always for unix, for tearoffs for Mac
#                       and Windows.
# activeMenu -          This is the last active menu for use
#                       with the <<MenuSelect>> virtual event.
# activeItem -          This is the last active menu item for
#                       use with the <<MenuSelect>> virtual event.
#-------------------------------------------------------------------------
 
#-------------------------------------------------------------------------
# Overall note:
# This file is tricky because there are five different ways that menus
# can be used:
#
# 1. As a pulldown from a menubutton. In this style, the variable 
#    tkPriv(postedMb) identifies the posted menubutton.
# 2. As a torn-off menu copied from some other menu.  In this style
#    tkPriv(postedMb) is empty, and menu's type is "tearoff".
# 3. As an option menu, triggered from an option menubutton.  In this
#    style tkPriv(postedMb) identifies the posted menubutton.
# 4. As a popup menu.  In this style tkPriv(postedMb) is empty and
#    the top-level menu's type is "normal".
# 5. As a pulldown from a menubar. The variable tkPriv(menubar) has
#    the owning menubar, and the menu itself is of type "normal".
#
# The various binding procedures use the  state described above to
# distinguish the various cases and take different actions in each
# case.
#-------------------------------------------------------------------------
 
#-------------------------------------------------------------------------
# The code below creates the default class bindings for menus
# and menubuttons.
#-------------------------------------------------------------------------
 
bind Menubutton <FocusIn> {}
bind Menubutton <Enter> {
    tkMbEnter %W
}
bind Menubutton <Leave> {
    tkMbLeave %W
}
bind Menubutton <1> {
    if {$tkPriv(inMenubutton) != ""} {
        tkMbPost $tkPriv(inMenubutton) %X %Y
    }
}
bind Menubutton <Motion> {
    tkMbMotion %W up %X %Y
}
bind Menubutton <B1-Motion> {
    tkMbMotion %W down %X %Y
}
bind Menubutton <ButtonRelease-1> {
    tkMbButtonUp %W
}
bind Menubutton <space> {
    tkMbPost %W
    tkMenuFirstEntry [%W cget -menu]
}
 
# Must set focus when mouse enters a menu, in order to allow
# mixed-mode processing using both the mouse and the keyboard.
# Don't set the focus if the event comes from a grab release,
# though:  such an event can happen after as part of unposting
# a cascaded chain of menus, after the focus has already been
# restored to wherever it was before menu selection started.
 
bind Menu <FocusIn> {}
 
bind Menu <Enter> {
    set tkPriv(window) %W
    if {[%W cget -type] == "tearoff"} {
        if {"%m" != "NotifyUngrab"} {
            if {$tcl_platform(platform) == "unix"} {
                tk_menuSetFocus %W
            }
        }
    }
    tkMenuMotion %W %x %y %s
}
 
bind Menu <Leave> {
    tkMenuLeave %W %X %Y %s
}
bind Menu <Motion> {
    tkMenuMotion %W %x %y %s
}
bind Menu <ButtonPress> {
    tkMenuButtonDown %W
}
bind Menu <ButtonRelease> {
   tkMenuInvoke %W 1
}
bind Menu <space> {
    tkMenuInvoke %W 0
}
bind Menu <Return> {
    tkMenuInvoke %W 0
}
bind Menu <Escape> {
    tkMenuEscape %W
}
bind Menu <Left> {
    tkMenuLeftArrow %W
}
bind Menu <Right> {
    tkMenuRightArrow %W
}
bind Menu <Up> {
    tkMenuUpArrow %W
}
bind Menu <Down> {
    tkMenuDownArrow %W
}
bind Menu <KeyPress> {
    tkTraverseWithinMenu %W %A
}
 
# The following bindings apply to all windows, and are used to
# implement keyboard menu traversal.
 
if {$tcl_platform(platform) == "unix"} {
    bind all <Alt-KeyPress> {
        tkTraverseToMenu %W %A
    }
 
    bind all <F10> {
        tkFirstMenu %W
    }
} else {
    bind Menubutton <Alt-KeyPress> {
        tkTraverseToMenu %W %A
    }
 
    bind Menubutton <F10> {
        tkFirstMenu %W
    }
}
 
# tkMbEnter --
# This procedure is invoked when the mouse enters a menubutton
# widget.  It activates the widget unless it is disabled.  Note:
# this procedure is only invoked when mouse button 1 is *not* down.
# The procedure tkMbB1Enter is invoked if the button is down.
#
# Arguments:
# w -                   The  name of the widget.
 
proc tkMbEnter w {
    global tkPriv
 
    if {$tkPriv(inMenubutton) != ""} {
        tkMbLeave $tkPriv(inMenubutton)
    }
    set tkPriv(inMenubutton) $w
    if {[$w cget -state] != "disabled"} {
        $w configure -state active
    }
}
 
# tkMbLeave --
# This procedure is invoked when the mouse leaves a menubutton widget.
# It de-activates the widget, if the widget still exists.
#
# Arguments:
# w -                   The  name of the widget.
 
proc tkMbLeave w {
    global tkPriv
 
    set tkPriv(inMenubutton) {}
    if {![winfo exists $w]} {
        return
    }
    if {[$w cget -state] == "active"} {
        $w configure -state normal
    }
}
 
# tkMbPost --
# Given a menubutton, this procedure does all the work of posting
# its associated menu and unposting any other menu that is currently
# posted.
#
# Arguments:
# w -                   The name of the menubutton widget whose menu
#                       is to be posted.
# x, y -                Root coordinates of cursor, used for positioning
#                       option menus.  If not specified, then the center
#                       of the menubutton is used for an option menu.
 
proc tkMbPost {w {x {}} {y {}}} {
    global tkPriv errorInfo
    global tcl_platform
 
    if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} {
        return
    }
    set menu [$w cget -menu]
    if {$menu == ""} {
        return
    }
    set tearoff [expr {($tcl_platform(platform) == "unix") \
                     || ([$menu cget -type] == "tearoff")}]
    if {[string first $w $menu] != 0} {
        error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
    }
    set cur $tkPriv(postedMb)
    if {$cur != ""} {
        tkMenuUnpost {}
    }
    set tkPriv(cursor) [$w cget -cursor]
    set tkPriv(relief) [$w cget -relief]
    $w configure -cursor arrow
    $w configure -relief raised
 
    set tkPriv(postedMb) $w
    set tkPriv(focus) [focus]
    $menu activate none
    tkGenerateMenuSelect $menu
 
    # If this looks like an option menubutton then post the menu so
    # that the current entry is on top of the mouse.  Otherwise post
    # the menu just below the menubutton, as for a pull-down.
 
    update idletasks
    if {[catch {
         switch [$w cget -direction] {
            above {
                set x [winfo rootx $w]
                set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
                $menu post $x $y
            }
            below {
                set x [winfo rootx $w]
                set y [expr {[winfo rooty $w] + [winfo height $w]}]
                $menu post $x $y
            }
            left {
                set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
                set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
                set entry [tkMenuFindName $menu [$w cget -text]]
                if {[$w cget -indicatoron]} {
                    if {$entry == [$menu index last]} {
                        incr y [expr {-([$menu yposition $entry] \
                                + [winfo reqheight $menu])/2}]
                    } else {
                        incr y [expr {-([$menu yposition $entry] \
                                + [$menu yposition [expr {$entry+1}]])/2}]
                    }
                }
                $menu post $x $y
                if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
                    $menu activate $entry
                    tkGenerateMenuSelect $menu
                }
            }
            right {
                set x [expr {[winfo rootx $w] + [winfo width $w]}]
                set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
                set entry [tkMenuFindName $menu [$w cget -text]]
                if {[$w cget -indicatoron]} {
                    if {$entry == [$menu index last]} {
                        incr y [expr {-([$menu yposition $entry] \
                                + [winfo reqheight $menu])/2}]
                    } else {
                        incr y [expr {-([$menu yposition $entry] \
                                + [$menu yposition [expr {$entry+1}]])/2}]
                    }
                }
                $menu post $x $y
                if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
                    $menu activate $entry
                    tkGenerateMenuSelect $menu
                }
            }
            default {
                if {[$w cget -indicatoron]} {
                    if {$y == ""} {
                        set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
                        set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
                    }
                    tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
                } else {
                    $menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
                }
            }
         }
     } msg]} {
        # Error posting menu (e.g. bogus -postcommand). Unpost it and
        # reflect the error.
 
        set savedInfo $errorInfo
        tkMenuUnpost {}
        error $msg $savedInfo
 
    }
 
    set tkPriv(tearoff) $tearoff
    if {$tearoff != 0} {
        focus $menu
        tkSaveGrabInfo $w
        grab -global $w
    }
}
 
# tkMenuUnpost --
# This procedure unposts a given menu, plus all of its ancestors up
# to (and including) a menubutton, if any.  It also restores various
# values to what they were before the menu was posted, and releases
# a grab if there's a menubutton involved.  Special notes:
# 1. It's important to unpost all menus before releasing the grab, so
#    that any Enter-Leave events (e.g. from menu back to main
#    application) have mode NotifyGrab.
# 2. Be sure to enclose various groups of commands in "catch" so that
#    the procedure will complete even if the menubutton or the menu
#    or the grab window has been deleted.
#
# Arguments:
# menu -                Name of a menu to unpost.  Ignored if there
#                       is a posted menubutton.
 
proc tkMenuUnpost menu {
    global tcl_platform
    global tkPriv
    set mb $tkPriv(postedMb)
 
    # Restore focus right away (otherwise X will take focus away when
    # the menu is unmapped and under some window managers (e.g. olvwm)
    # we'll lose the focus completely).
 
    catch {focus $tkPriv(focus)}
    set tkPriv(focus) ""
 
    # Unpost menu(s) and restore some stuff that's dependent on
    # what was posted.
 
    catch {
        if {$mb != ""} {
            set menu [$mb cget -menu]
            $menu unpost
            set tkPriv(postedMb) {}
            $mb configure -cursor $tkPriv(cursor)
            $mb configure -relief $tkPriv(relief)
        } elseif {$tkPriv(popup) != ""} {
            $tkPriv(popup) unpost
            set tkPriv(popup) {}
        } elseif {(!([$menu cget -type] == "menubar")
                && !([$menu cget -type] == "tearoff"))} {
            # We're in a cascaded sub-menu from a torn-off menu or popup.
            # Unpost all the menus up to the toplevel one (but not
            # including the top-level torn-off one) and deactivate the
            # top-level torn off menu if there is one.
 
            while 1 {
                set parent [winfo parent $menu]
                if {([winfo class $parent] != "Menu")
                        || ![winfo ismapped $parent]} {
                    break
                }
                $parent activate none
                $parent postcascade none
                tkGenerateMenuSelect $parent
                set type [$parent cget -type]
                if {($type == "menubar")|| ($type == "tearoff")} {
                    break
                }
                set menu $parent
            }
            if {[$menu cget -type] != "menubar"} {
                $menu unpost
            }
        }
    }
 
    if {($tkPriv(tearoff) != 0) || ($tkPriv(menuBar) != "")} {
        # Release grab, if any, and restore the previous grab, if there
        # was one.
 
        if {$menu != ""} {
            set grab [grab current $menu]
            if {$grab != ""} {
                grab release $grab
            }
        }
        tkRestoreOldGrab
        if {$tkPriv(menuBar) != ""} {
            $tkPriv(menuBar) configure -cursor $tkPriv(cursor)
            set tkPriv(menuBar) {}
        }
        if {$tcl_platform(platform) != "unix"} {
            set tkPriv(tearoff) 0
        }
    }
}
 
# tkMbMotion --
# This procedure handles mouse motion events inside menubuttons, and
# also outside menubuttons when a menubutton has a grab (e.g. when a
# menu selection operation is in progress).
#
# Arguments:
# w -                   The name of the menubutton widget.
# upDown -              "down" means button 1 is pressed, "up" means
#                       it isn't.
# rootx, rooty -        Coordinates of mouse, in (virtual?) root window.
 
proc tkMbMotion {w upDown rootx rooty} {
    global tkPriv
 
    if {$tkPriv(inMenubutton) == $w} {
        return
    }
    set new [winfo containing $rootx $rooty]
    if {($new != $tkPriv(inMenubutton)) && (($new == "")
            || ([winfo toplevel $new] == [winfo toplevel $w]))} {
        if {$tkPriv(inMenubutton) != ""} {
            tkMbLeave $tkPriv(inMenubutton)
        }
        if {($new != "") && ([winfo class $new] == "Menubutton")
                && ([$new cget -indicatoron] == 0)
                && ([$w cget -indicatoron] == 0)} {
            if {$upDown == "down"} {
                tkMbPost $new $rootx $rooty
            } else {
                tkMbEnter $new
            }
        }
    }
}
 
# tkMbButtonUp --
# This procedure is invoked to handle button 1 releases for menubuttons.
# If the release happens inside the menubutton then leave its menu
# posted with element 0 activated.  Otherwise, unpost the menu.
#
# Arguments:
# w -                   The name of the menubutton widget.
 
proc tkMbButtonUp w {
    global tkPriv
    global tcl_platform
 
    set tearoff [expr {($tcl_platform(platform) == "unix") \
                     || ([[$w cget -menu] cget -type] == "tearoff")}]
    if {($tearoff != 0) && ($tkPriv(postedMb) == $w)
            && ($tkPriv(inMenubutton) == $w)} {
        tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
    } else {
        tkMenuUnpost {}
    }
}
 
# tkMenuMotion --
# This procedure is called to handle mouse motion events for menus.
# It does two things.  First, it resets the active element in the
# menu, if the mouse is over the menu.  Second, if a mouse button
# is down, it posts and unposts cascade entries to match the mouse
# position.
#
# Arguments:
# menu -                The menu window.
# x -                   The x position of the mouse.
# y -                   The y position of the mouse.
# state -               Modifier state (tells whether buttons are down).
 
proc tkMenuMotion {menu x y state} {
    global tkPriv
    if {$menu == $tkPriv(window)} {
        if {[$menu cget -type] == "menubar"} {
            if {[info exists tkPriv(focus)] && \
                    ([string compare $menu $tkPriv(focus)] != 0)} {
                $menu activate @$x,$y
                tkGenerateMenuSelect $menu
            }
        } else {
            $menu activate @$x,$y
            tkGenerateMenuSelect $menu
        }
    }
    if {($state & 0x1f00) != 0} {
        $menu postcascade active
    }
}
 
# tkMenuButtonDown --
# Handles button presses in menus.  There are a couple of tricky things
# here:
# 1. Change the posted cascade entry (if any) to match the mouse position.
# 2. If there is a posted menubutton, must grab to the menubutton;  this
#    overrrides the implicit grab on button press, so that the menu
#    button can track mouse motions over other menubuttons and change
#    the posted menu.
# 3. If there's no posted menubutton (e.g. because we're a torn-off menu
#    or one of its descendants) must grab to the top-level menu so that
#    we can track mouse motions across the entire menu hierarchy.
#
# Arguments:
# menu -                The menu window.
 
proc tkMenuButtonDown menu {
    global tkPriv
    global tcl_platform
    $menu postcascade active
    if {$tkPriv(postedMb) != ""} {
        grab -global $tkPriv(postedMb)
    } else {
        while {([$menu cget -type] == "normal")
                && ([winfo class [winfo parent $menu]] == "Menu")
                && [winfo ismapped [winfo parent $menu]]} {
            set menu [winfo parent $menu]
        }
 
        if {$tkPriv(menuBar) == {}} {
            set tkPriv(menuBar) $menu
            set tkPriv(cursor) [$menu cget -cursor]
            $menu configure -cursor arrow
        }
 
        # Don't update grab information if the grab window isn't changing.
        # Otherwise, we'll get an error when we unpost the menus and
        # restore the grab, since the old grab window will not be viewable
        # anymore.
 
        if {$menu != [grab current $menu]} {
            tkSaveGrabInfo $menu
        }
 
        # Must re-grab even if the grab window hasn't changed, in order
        # to release the implicit grab from the button press.
 
        if {$tcl_platform(platform) == "unix"} {
            grab -global $menu
        }
    }
}
 
# tkMenuLeave --
# This procedure is invoked to handle Leave events for a menu.  It
# deactivates everything unless the active element is a cascade element
# and the mouse is now over the submenu.
#
# Arguments:
# menu -                The menu window.
# rootx, rooty -        Root coordinates of mouse.
# state -               Modifier state.
 
proc tkMenuLeave {menu rootx rooty state} {
    global tkPriv
    set tkPriv(window) {}
    if {[$menu index active] == "none"} {
        return
    }
    if {([$menu type active] == "cascade")
            && ([winfo containing $rootx $rooty]
            == [$menu entrycget active -menu])} {
        return
    }
    $menu activate none
    tkGenerateMenuSelect $menu
}
 
# tkMenuInvoke --
# This procedure is invoked when button 1 is released over a menu.
# It invokes the appropriate menu action and unposts the menu if
# it came from a menubutton.
#
# Arguments:
# w -                   Name of the menu widget.
# buttonRelease -       1 means this procedure is called because of
#                       a button release;  0 means because of keystroke.
 
proc tkMenuInvoke {w buttonRelease} {
    global tkPriv
 
    if {$buttonRelease && ($tkPriv(window) == "")} {
        # Mouse was pressed over a menu without a menu button, then
        # dragged off the menu (possibly with a cascade posted) and
        # released.  Unpost everything and quit.
 
        $w postcascade none
        $w activate none
        event generate $w <<MenuSelect>>
        tkMenuUnpost $w
        return
    }
    if {[$w type active] == "cascade"} {
        $w postcascade active
        set menu [$w entrycget active -menu]
        tkMenuFirstEntry $menu
    } elseif {[$w type active] == "tearoff"} {
        tkMenuUnpost $w
        tkTearOffMenu $w
    } elseif {[$w cget -type] == "menubar"} {
        $w postcascade none
        $w activate none
        event generate $w <<MenuSelect>>
        tkMenuUnpost $w
    } else {
        tkMenuUnpost $w
        uplevel #0 [list $w invoke active]
    }
}
 
# tkMenuEscape --
# This procedure is invoked for the Cancel (or Escape) key.  It unposts
# the given menu and, if it is the top-level menu for a menu button,
# unposts the menu button as well.
#
# Arguments:
# menu -                Name of the menu window.
 
proc tkMenuEscape menu {
    set parent [winfo parent $menu]
    if {([winfo class $parent] != "Menu")} {
        tkMenuUnpost $menu
    } elseif {([$parent cget -type] == "menubar")} {
        tkMenuUnpost $menu
        tkRestoreOldGrab
    } else {
        tkMenuNextMenu $menu left
    }
}
 
# The following routines handle arrow keys. Arrow keys behave
# differently depending on whether the menu is a menu bar or not.
 
proc tkMenuUpArrow {menu} {
    if {[$menu cget -type] == "menubar"} {
        tkMenuNextMenu $menu left
    } else {
        tkMenuNextEntry $menu -1
    }
}
 
proc tkMenuDownArrow {menu} {
    if {[$menu cget -type] == "menubar"} {
        tkMenuNextMenu $menu right
    } else {
        tkMenuNextEntry $menu 1
    }
}
 
proc tkMenuLeftArrow {menu} {
    if {[$menu cget -type] == "menubar"} {
        tkMenuNextEntry $menu -1
    } else {
        tkMenuNextMenu $menu left
    }
}
 
proc tkMenuRightArrow {menu} {
    if {[$menu cget -type] == "menubar"} {
        tkMenuNextEntry $menu 1
    } else {
        tkMenuNextMenu $menu right
    }
}
 
# tkMenuNextMenu --
# This procedure is invoked to handle "left" and "right" traversal
# motions in menus.  It traverses to the next menu in a menu bar,
# or into or out of a cascaded menu.
#
# Arguments:
# menu -                The menu that received the keyboard
#                       event.
# direction -           Direction in which to move: "left" or "right"
 
proc tkMenuNextMenu {menu direction} {
    global tkPriv
 
    # First handle traversals into and out of cascaded menus.
 
    if {$direction == "right"} {
        set count 1
        set parent [winfo parent $menu]
        set class [winfo class $parent]
        if {[$menu type active] == "cascade"} {
            $menu postcascade active
            set m2 [$menu entrycget active -menu]
            if {$m2 != ""} {
                tkMenuFirstEntry $m2
            }
            return
        } else {
            set parent [winfo parent $menu]
            while {($parent != ".")} {
                if {([winfo class $parent] == "Menu")
                        && ([$parent cget -type] == "menubar")} {
                    tk_menuSetFocus $parent
                    tkMenuNextEntry $parent 1
                    return
                }
                set parent [winfo parent $parent]
            }
        }
    } else {
        set count -1
        set m2 [winfo parent $menu]
        if {[winfo class $m2] == "Menu"} {
            if {[$m2 cget -type] != "menubar"} {
                $menu activate none
                tkGenerateMenuSelect $menu
                tk_menuSetFocus $m2
 
                # This code unposts any posted submenu in the parent.
 
                set tmp [$m2 index active]
                $m2 activate none
                $m2 activate $tmp
                return
            }
        }
    }
 
    # Can't traverse into or out of a cascaded menu.  Go to the next
    # or previous menubutton, if that makes sense.
 
    set m2 [winfo parent $menu]
    if {[winfo class $m2] == "Menu"} {
        if {[$m2 cget -type] == "menubar"} {
            tk_menuSetFocus $m2
            tkMenuNextEntry $m2 -1
            return
        }
    }
 
    set w $tkPriv(postedMb)
    if {$w == ""} {
        return
    }
    set buttons [winfo children [winfo parent $w]]
    set length [llength $buttons]
    set i [expr {[lsearch -exact $buttons $w] + $count}]
    while 1 {
        while {$i < 0} {
            incr i $length
        }
        while {$i >= $length} {
            incr i -$length
        }
        set mb [lindex $buttons $i]
        if {([winfo class $mb] == "Menubutton")
                && ([$mb cget -state] != "disabled")
                && ([$mb cget -menu] != "")
                && ([[$mb cget -menu] index last] != "none")} {
            break
        }
        if {$mb == $w} {
            return
        }
        incr i $count
    }
    tkMbPost $mb
    tkMenuFirstEntry [$mb cget -menu]
}
 
# tkMenuNextEntry --
# Activate the next higher or lower entry in the posted menu,
# wrapping around at the ends.  Disabled entries are skipped.
#
# Arguments:
# menu -                        Menu window that received the keystroke.
# count -                       1 means go to the next lower entry,
#                               -1 means go to the next higher entry.
 
proc tkMenuNextEntry {menu count} {
    global tkPriv
 
    if {[$menu index last] == "none"} {
        return
    }
    set length [expr {[$menu index last]+1}]
    set quitAfter $length
    set active [$menu index active]
    if {$active == "none"} {
        set i 0
    } else {
        set i [expr {$active + $count}]
    }
    while 1 {
        if {$quitAfter <= 0} {
            # We've tried every entry in the menu.  Either there are
            # none, or they're all disabled.  Just give up.
 
            return
        }
        while {$i < 0} {
            incr i $length
        }
        while {$i >= $length} {
            incr i -$length
        }
        if {[catch {$menu entrycget $i -state} state] == 0} {
            if {$state != "disabled"} {
                break
            }
        }
        if {$i == $active} {
            return
        }
        incr i $count
        incr quitAfter -1
    }
    $menu activate $i
    tkGenerateMenuSelect $menu
    if {[$menu type $i] == "cascade"} {
        set cascade [$menu entrycget $i -menu]
        if {[string compare $cascade ""] != 0} {
            $menu postcascade $i
            tkMenuFirstEntry $cascade
        }
    }
}
 
# tkMenuFind --
# This procedure searches the entire window hierarchy under w for
# a menubutton that isn't disabled and whose underlined character
# is "char" or an entry in a menubar that isn't disabled and whose
# underlined character is "char".
# It returns the name of that window, if found, or an
# empty string if no matching window was found.  If "char" is an
# empty string then the procedure returns the name of the first
# menubutton found that isn't disabled.
#
# Arguments:
# w -                           Name of window where key was typed.
# char -                        Underlined character to search for;
#                               may be either upper or lower case, and
#                               will match either upper or lower case.
 
proc tkMenuFind {w char} {
    global tkPriv
    set char [string tolower $char]
    set windowlist [winfo child $w]
 
    foreach child $windowlist {
        switch [winfo class $child] {
            Menu {
                if {[$child cget -type] == "menubar"} {
                    if {$char == ""} {
                        return $child
                    }
                    set last [$child index last]
                    for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
                        if {[$child type $i] == "separator"} {
                            continue
                        }
                        set char2 [string index [$child entrycget $i -label] \
                                [$child entrycget $i -underline]]
                        if {([string compare $char [string tolower $char2]] \
                                == 0) || ($char == "")} {
                            if {[$child entrycget $i -state] != "disabled"} {
                                return $child
                            }
                        }
                    }
                }
            }
        }
    }
 
    foreach child $windowlist {
        switch [winfo class $child] {
            Menubutton {
                set char2 [string index [$child cget -text] \
                        [$child cget -underline]]
                if {([string compare $char [string tolower $char2]] == 0)
                        || ($char == "")} {
                    if {[$child cget -state] != "disabled"} {
                        return $child
                    }
                }
            }
 
            default {
                set match [tkMenuFind $child $char]
                if {$match != ""} {
                    return $match
                }
            }
        }
    }
    return {}
}
 
# tkTraverseToMenu --
# This procedure implements keyboard traversal of menus.  Given an
# ASCII character "char", it looks for a menubutton with that character
# underlined.  If one is found, it posts the menubutton's menu
#
# Arguments:
# w -                           Window in which the key was typed (selects
#                               a toplevel window).
# char -                        Character that selects a menu.  The case
#                               is ignored.  If an empty string, nothing
#                               happens.
 
proc tkTraverseToMenu {w char} {
    global tkPriv
    if {$char == ""} {
        return
    }
    while {[winfo class $w] == "Menu"} {
        if {([$w cget -type] != "menubar") && ($tkPriv(postedMb) == "")} {
            return
        }
        if {[$w cget -type] == "menubar"} {
            break
        }
        set w [winfo parent $w]
    }
    set w [tkMenuFind [winfo toplevel $w] $char]
    if {$w != ""} {
        if {[winfo class $w] == "Menu"} {
            tk_menuSetFocus $w
            set tkPriv(window) $w
            tkSaveGrabInfo $w
            grab -global $w
            tkTraverseWithinMenu $w $char
        } else {
            tkMbPost $w
            tkMenuFirstEntry [$w cget -menu]
        }
    }
}
 
# tkFirstMenu --
# This procedure traverses to the first menubutton in the toplevel
# for a given window, and posts that menubutton's menu.
#
# Arguments:
# w -                           Name of a window.  Selects which toplevel
#                               to search for menubuttons.
 
proc tkFirstMenu w {
    set w [tkMenuFind [winfo toplevel $w] ""]
    if {$w != ""} {
        if {[winfo class $w] == "Menu"} {
            tk_menuSetFocus $w
            set tkPriv(window) $w
            tkSaveGrabInfo $w
            grab -global $w
            tkMenuFirstEntry $w
        } else {
            tkMbPost $w
            tkMenuFirstEntry [$w cget -menu]
        }
    }
}
 
# tkTraverseWithinMenu
# This procedure implements keyboard traversal within a menu.  It
# searches for an entry in the menu that has "char" underlined.  If
# such an entry is found, it is invoked and the menu is unposted.
#
# Arguments:
# w -                           The name of the menu widget.
# char -                        The character to look for;  case is
#                               ignored.  If the string is empty then
#                               nothing happens.
 
proc tkTraverseWithinMenu {w char} {
    if {$char == ""} {
        return
    }
    set char [string tolower $char]
    set last [$w index last]
    if {$last == "none"} {
        return
    }
    for {set i 0} {$i <= $last} {incr i} {
        if {[catch {set char2 [string index \
                [$w entrycget $i -label] \
                [$w entrycget $i -underline]]}]} {
            continue
        }
        if {[string compare $char [string tolower $char2]] == 0} {
            if {[$w type $i] == "cascade"} {
                $w activate $i
                $w postcascade active
                event generate $w <<MenuSelect>>
                set m2 [$w entrycget $i -menu]
                if {$m2 != ""} {
                    tkMenuFirstEntry $m2
                }
            } else {
                tkMenuUnpost $w
                uplevel #0 [list $w invoke $i]
            }
            return
        }
    }
}
 
# tkMenuFirstEntry --
# Given a menu, this procedure finds the first entry that isn't
# disabled or a tear-off or separator, and activates that entry.
# However, if there is already an active entry in the menu (e.g.,
# because of a previous call to tkPostOverPoint) then the active
# entry isn't changed.  This procedure also sets the input focus
# to the menu.
#
# Arguments:
# menu -                Name of the menu window (possibly empty).
 
proc tkMenuFirstEntry menu {
    if {$menu == ""} {
        return
    }
    tk_menuSetFocus $menu
    if {[$menu index active] != "none"} {
        return
    }
    set last [$menu index last]
    if {$last == "none"} {
        return
    }
    for {set i 0} {$i <= $last} {incr i} {
        if {([catch {set state [$menu entrycget $i -state]}] == 0)
                && ($state != "disabled") && ([$menu type $i] != "tearoff")} {
            $menu activate $i
            tkGenerateMenuSelect $menu
            if {[$menu type $i] == "cascade"} {
                set cascade [$menu entrycget $i -menu]
                if {[string compare $cascade ""] != 0} {
                    $menu postcascade $i
                    tkMenuFirstEntry $cascade
                }
            }
            return
        }
    }
}
 
# tkMenuFindName --
# Given a menu and a text string, return the index of the menu entry
# that displays the string as its label.  If there is no such entry,
# return an empty string.  This procedure is tricky because some names
# like "active" have a special meaning in menu commands, so we can't
# always use the "index" widget command.
#
# Arguments:
# menu -                Name of the menu widget.
# s -                   String to look for.
 
proc tkMenuFindName {menu s} {
    set i ""
    if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
        catch {set i [$menu index $s]}
        return $i
    }
    set last [$menu index last]
    if {$last == "none"} {
        return
    }
    for {set i 0} {$i <= $last} {incr i} {
        if {![catch {$menu entrycget $i -label} label]} {
            if {$label == $s} {
                return $i
            }
        }
    }
    return ""
}
 
# tkPostOverPoint --
# This procedure posts a given menu such that a given entry in the
# menu is centered over a given point in the root window.  It also
# activates the given entry.
#
# Arguments:
# menu -                Menu to post.
# x, y -                Root coordinates of point.
# entry -               Index of entry within menu to center over (x,y).
#                       If omitted or specified as {}, then the menu's
#                       upper-left corner goes at (x,y).
 
proc tkPostOverPoint {menu x y {entry {}}}  {
    global tcl_platform
 
    if {$entry != {}} {
        if {$entry == [$menu index last]} {
            incr y [expr {-([$menu yposition $entry] \
                    + [winfo reqheight $menu])/2}]
        } else {
            incr y [expr {-([$menu yposition $entry] \
                    + [$menu yposition [expr {$entry+1}]])/2}]
        }
        incr x [expr {-[winfo reqwidth $menu]/2}]
    }
    $menu post $x $y
    if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} {
        $menu activate $entry
        tkGenerateMenuSelect $menu
    }
}
 
# tkSaveGrabInfo --
# Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record
# the state of any existing grab on the w's display.
#
# Arguments:
# w -                   Name of a window;  used to select the display
#                       whose grab information is to be recorded.
 
proc tkSaveGrabInfo w {
    global tkPriv
    set tkPriv(oldGrab) [grab current $w]
    if {$tkPriv(oldGrab) != ""} {
        set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]
    }
}
 
# tkRestoreOldGrab --
# Restores the grab to what it was before TkSaveGrabInfo was called.
#
 
proc tkRestoreOldGrab {} {
    global tkPriv
 
    if {$tkPriv(oldGrab) != ""} {
 
        # Be careful restoring the old grab, since it's window may not
        # be visible anymore.
 
        catch {
            if {$tkPriv(grabStatus) == "global"} {
                grab set -global $tkPriv(oldGrab)
            } else {
                grab set $tkPriv(oldGrab)
            }
        }
        set tkPriv(oldGrab) ""
    }
}
 
proc tk_menuSetFocus {menu} {
    global tkPriv
    if {![info exists tkPriv(focus)] || [string length $tkPriv(focus)] == 0} {
        set tkPriv(focus) [focus]
    }
    focus $menu
}
 
proc tkGenerateMenuSelect {menu} {
    global tkPriv
 
    if {([string compare $tkPriv(activeMenu) $menu] == 0) \
            && ([string compare $tkPriv(activeItem) [$menu index active]] \
            == 0)} {
        return
    }
 
    set tkPriv(activeMenu) $menu
    set tkPriv(activeItem) [$menu index active]
    event generate $menu <<MenuSelect>>
}
 
# tk_popup --
# This procedure pops up a menu and sets things up for traversing
# the menu and its submenus.
#
# Arguments:
# menu -                Name of the menu to be popped up.
# x, y -                Root coordinates at which to pop up the
#                       menu.
# entry -               Index of a menu entry to center over (x,y).
#                       If omitted or specified as {}, then menu's
#                       upper-left corner goes at (x,y).
 
proc tk_popup {menu x y {entry {}}} {
    global tkPriv
    global tcl_platform
    if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} {
        tkMenuUnpost {}
    }
    tkPostOverPoint $menu $x $y $entry
    if {$tcl_platform(platform) == "unix"} {
        tkSaveGrabInfo $menu
        grab -global $menu
        set tkPriv(popup) $menu
        tk_menuSetFocus $menu
    }
}
Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tk/] [library/] [menu.tcl] - Blame information for rev 1765
