menu.tcl

genesis 2000 v9.1软件下载

	    # 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
		event generate $parent <<MenuSelect>>
		if {([$parent cget -type] == "menubar")
		        || ![wm overrideredirect $parent]} {
		    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
		event generate $menu <<MenuSelect>>
	    }
	} else {
	    $menu activate @$x,$y
	    event generate $menu <<MenuSelect>>
	}
    }
    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] != "menubar") 
		&& [wm overrideredirect $menu])
		&& ([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
    event generate $menu <<MenuSelect>>
}

# 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"} {
	    $menu activate none
	    event generate $menu <<MenuSelect>>
	    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 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,