menu.tcl

基于语义本体的单词查询系统

    if {($tkPriv(tearoff) != 0) || [string compare $tkPriv(menuBar) ""]} {
    	# Release grab, if any, and restore the previous grab, if there
    	# was one.
	if {[string compare $menu ""]} {
	    set grab [grab current $menu]
	    if {[string compare $grab ""]} {
		grab release $grab
	    }
	}
	tkRestoreOldGrab
	if {[string compare $tkPriv(menuBar) ""]} {
	    $tkPriv(menuBar) configure -cursor $tkPriv(cursor)
	    set tkPriv(menuBar) {}
	}
	if {[string compare $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 {[string equal $tkPriv(inMenubutton) $w]} {
	return
    }
    set new [winfo containing $rootx $rooty]
    if {[string compare $new $tkPriv(inMenubutton)] \
	    && ([string equal $new ""] \
	    || [string equal [winfo toplevel $new] [winfo toplevel $w]])} {
	if {[string compare $tkPriv(inMenubutton) ""]} {
	    tkMbLeave $tkPriv(inMenubutton)
	}
	if {[string compare $new ""] \
		&& [string equal [winfo class $new] "Menubutton"] \
		&& ([$new cget -indicatoron] == 0) \
		&& ([$w cget -indicatoron] == 0)} {
	    if {[string equal $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 menu [$w cget -menu]
    set tearoff [expr {[string equal $tcl_platform(platform) "unix"] || \
	    ([string compare $menu {}] && \
	    [string equal [$menu cget -type] "tearoff"])}]
    if {($tearoff != 0) && [string equal $tkPriv(postedMb) $w] \
	    && [string equal $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 {[string equal $menu $tkPriv(window)]} {
	if {[string equal [$menu cget -type] "menubar"]} {
	    if {[info exists tkPriv(focus)] && \
		    [string compare $menu $tkPriv(focus)]} {
		$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

    if {![winfo viewable $menu]} {
        return
    }
    $menu postcascade active
    if {[string compare $tkPriv(postedMb) ""] && \
	    [winfo viewable $tkPriv(postedMb)]} {
	grab -global $tkPriv(postedMb)
    } else {
	while {[string equal [$menu cget -type] "normal"] \
		&& [string equal [winfo class [winfo parent $menu]] "Menu"] \
		&& [winfo ismapped [winfo parent $menu]]} {
	    set menu [winfo parent $menu]
	}

	if {[string equal $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 {[string compare $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 {[string equal $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 {[string equal [$menu index active] "none"]} {
	return
    }
    if {[string equal [$menu type active] "cascade"]
          && [string equal [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 && [string equal $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 {[string equal [$w type active] "cascade"]} {
	$w postcascade active
	set menu [$w entrycget active -menu]
	tkMenuFirstEntry $menu
    } elseif {[string equal [$w type active] "tearoff"]} {
	tkTearOffMenu $w
	tkMenuUnpost $w
    } elseif {[string equal [$w cget -type] "menubar"]} {
	$w postcascade none
	set active [$w index active]
	set isCascade [string equal [$w type $active] "cascade"]

	# Only de-activate the active item if it's a cascade; this prevents
	# the annoying "activation flicker" you otherwise get with 
	# checkbuttons/commands/etc. on menubars

	if { $isCascade } {
	    $w activate none
	    event generate $w <<MenuSelect>>
	}

	tkMenuUnpost $w

	# If the active item is not a cascade, invoke it.  This enables
	# the use of checkbuttons/commands/etc. on menubars (which is legal,
	# but not recommended)

	if { !$isCascade } {
	    uplevel #0 [list $w invoke $active]
	}
    } 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 {[string compare [winfo class $parent] "Menu"]} {
	tkMenuUnpost $menu
    } elseif {[string equal [$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 {[string equal [$menu cget -type] "menubar"]} {
	tkMenuNextMenu $menu left
    } else {
	tkMenuNextEntry $menu -1
    }
}

proc tkMenuDownArrow {menu} {
    if {[string equal [$menu cget -type] "menubar"]} {
	tkMenuNextMenu $menu right
    } else {
	tkMenuNextEntry $menu 1
    }
}

proc tkMenuLeftArrow {menu} {
    if {[string equal [$menu cget -type] "menubar"]} {
	tkMenuNextEntry $menu -1
    } else {
	tkMenuNextMenu $menu left
    }
}

proc tkMenuRightArrow {menu} {
    if {[string equal [$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 {[string equal $direction "right"]} {
	set count 1
	set parent [winfo parent $menu]
	set class [winfo class $parent]
	if {[string equal [$menu type active] "cascade"]} {
	    $menu postcascade active
	    set m2 [$menu entrycget active -menu]
	    if {[string compare $m2 ""]} {
		tkMenuFirstEntry $m2
	    }
	    return
	} else {
	    set parent [winfo parent $menu]
	    while {[string compare $parent "."]} {
		if {[string equal [winfo class $parent] "Menu"] \
			&& [string equal [$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 {[string equal [winfo class $m2] "Menu"]} {
	    if {[string compare [$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 {[string equal [winfo class $m2] "Menu"]} {
	if {[string equal [$m2 cget -type] "menubar"]} {
	    tk_menuSetFocus $m2
	    tkMenuNextEntry $m2 -1
	    return
	}
    }

    set w $tkPriv(postedMb)
    if {[string equal $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 {[string equal [winfo class $mb] "Menubutton"] \
		&& [string compare [$mb cget -state] "disabled"] \
		&& [string compare [$mb cget -menu] ""] \
		&& [string compare [[$mb cget -menu] index last] "none"]} {
	    break
	}
	if {[string equal $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 {[string equal [$menu index last] "none"]} {
	return
    }
    set length [expr {[$menu index last]+1}]
    set quitAfter $length
    set active [$menu index active]
    if {[string equal $active "none"]} {
	set i 0