menu.tcl

genesis 2000 v9.1软件下载

# 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.97 97/08/13 10:58:34
#
# 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.
#-------------------------------------------------------------------------

#-------------------------------------------------------------------------
# Overall note:
# This file is tricky because there are four different ways that menus
# can be used:
#
# 1. As a pulldown from a menubutton.  This is the most common usage.
#    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 the top-level menu is no
#    override-redirect.
# 3. As an option menu, triggered from an option menubutton.  In thi
#    style tkPriv(postedMb) identifies the posted menubutton.
# 4. As a popup menu.  In this style tkPriv(postedMb) is empty and
#    the top-level menu is override-redirect.
#
# 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
    event generate $menu <<MenuSelect>>

    # 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
		    event generate $menu <<MenuSelect>>
    	    	}
    	    }
    	    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
		    event generate $menu <<MenuSelect>>
    	    	}
    	    }
    	    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"))
		|| [wm overrideredirect $menu]} {
	    # 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