menu.tcl

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

    } 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 {[string compare $state "disabled"]} {
		break
	    }
	}
	if {$i == $active} {
	    return
	}
	incr i $count
	incr quitAfter -1
    }
    $menu activate $i
    tkGenerateMenuSelect $menu
    if {[string equal [$menu type $i] "cascade"]} {
	set cascade [$menu entrycget $i -menu]
	if {[string compare $cascade ""]} {
	    # Here we auto-post a cascade.  This is necessary when
	    # we traverse left/right in the menubar, but undesirable when
	    # we traverse up/down in a menu.
	    $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 {
	# Don't descend into other toplevels.
        if {[string compare [winfo toplevel [focus]] \
		[winfo toplevel $child]]} {
	    continue
	}
	if {[string equal [winfo class $child] "Menu"] && \
		[string equal [$child cget -type] "menubar"]} {
	    if {[string equal $char ""]} {
		return $child
	    }
	    set last [$child index last]
	    for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
		if {[string equal [$child type $i] "separator"]} {
		    continue
		}
		set char2 [string index [$child entrycget $i -label] \
			[$child entrycget $i -underline]]
		if {[string equal $char [string tolower $char2]] \
			|| [string equal $char ""]} {
		    if {[string compare [$child entrycget $i -state] "disabled"]} {
			return $child
		    }
		}
	    }
	}
    }

    foreach child $windowlist {
	# Don't descend into other toplevels.
        if {[string compare [winfo toplevel [focus]] \
		[winfo toplevel $child]]} {
	    continue
	}
	switch [winfo class $child] {
	    Menubutton {
		set char2 [string index [$child cget -text] \
			[$child cget -underline]]
		if {[string equal $char [string tolower $char2]] \
			|| [string equal $char ""]} {
		    if {[string compare [$child cget -state] "disabled"]} {
			return $child
		    }
		}
	    }

	    default {
		set match [tkMenuFind $child $char]
		if {[string compare $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 {[string equal $char ""]} {
	return
    }
    while {[string equal [winfo class $w] "Menu"]} {
	if {[string compare [$w cget -type] "menubar"] \
		&& [string equal $tkPriv(postedMb) ""]} {
	    return
	}
	if {[string equal [$w cget -type] "menubar"]} {
	    break
	}
	set w [winfo parent $w]
    }
    set w [tkMenuFind [winfo toplevel $w] $char]
    if {[string compare $w ""]} {
	if {[string equal [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 {[string compare $w ""]} {
	if {[string equal [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 {[string equal $char ""]} {
	return
    }
    set char [string tolower $char]
    set last [$w index last]
    if {[string equal $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 equal $char [string tolower $char2]]} {
	    if {[string equal [$w type $i] "cascade"]} {
		$w activate $i
		$w postcascade active
		event generate $w <<MenuSelect>>
		set m2 [$w entrycget $i -menu]
		if {[string compare $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 {[string equal $menu ""]} {
	return
    }
    tk_menuSetFocus $menu
    if {[string compare [$menu index active] "none"]} {
	return
    }
    set last [$menu index last]
    if {[string equal $last "none"]} {
	return
    }
    for {set i 0} {$i <= $last} {incr i} {
	if {([catch {set state [$menu entrycget $i -state]}] == 0) \
		&& [string compare $state "disabled"] \
		&& [string compare [$menu type $i] "tearoff"]} {
	    $menu activate $i
	    tkGenerateMenuSelect $menu
	    # Only post the cascade if the current menu is a menubar;
	    # otherwise, if the first entry of the cascade is a cascade,
	    # we can get an annoying cascading effect resulting in a bunch of
	    # menus getting posted (bug 676)
	    if {[string equal [$menu type $i] "cascade"] && \
		[string equal [$menu cget -type] "menubar"]} {
		set cascade [$menu entrycget $i -menu]
		if {[string compare $cascade ""]} {
		    $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 {[string equal $last "none"]} {
	return
    }
    for {set i 0} {$i <= $last} {incr i} {
	if {![catch {$menu entrycget $i -label} label]} {
	    if {[string equal $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 {[string compare $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 {[string compare $entry {}] \
	    && [string compare [$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 {[string compare $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 {[string compare $tkPriv(oldGrab) ""]} {

    	# Be careful restoring the old grab, since it's window may not
	# be visible anymore.

	catch {
          if {[string equal $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 equal $tkPriv(focus) {}]} {
	set tkPriv(focus) [focus]
    }
    focus $menu
}
    
proc tkGenerateMenuSelect {menu} {
    global tkPriv

    if {[string equal $tkPriv(activeMenu) $menu] \
          && [string equal $tkPriv(activeItem) [$menu index active]]} {
	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 {[string compare $tkPriv(popup) ""] \
	    || [string compare $tkPriv(postedMb) ""]} {
	tkMenuUnpost {}
    }
    tkPostOverPoint $menu $x $y $entry
    if {[string equal $tcl_platform(platform) "unix"] \
	    && [winfo viewable $menu]} {
        tkSaveGrabInfo $menu
	grab -global $menu
	set tkPriv(popup) $menu
	tk_menuSetFocus $menu
    }
}