# this file from tkabber project
# http://www.jabberstudio.org/projects/tkabber/
namespace eval :: {
proc myMenuButtonDown {args} {
global myMenuFlag myMenuMotion
eval ::tk::MenuButtonDown $args
set myMenuFlag 1
}
proc myMenuInvoke {args} {
global myMenuFlag myMenuMotion
if {$myMenuFlag || $myMenuMotion} {
eval ::tk::MenuInvoke $args
}
set myMenuFlag 0
set myMenuMotion 0
}
proc myMenuMotion {args} {
global myMenuFlag myMenuMotion
eval ::tk::MenuMotion $args
set myMenuMotion 1
}
proc myMenuLeave {args} {
global myMenuFlag myMenuMotion
eval ::tk::MenuLeave $args
set myMenuMotion 0
}
bind Menu <Leave> {myMenuLeave %W %X %Y %s}
bind Menu <ButtonPress> {myMenuButtonDown %W}
bind Menu <ButtonRelease> {myMenuInvoke %W 1}
bind Menu <Motion> {myMenuMotion %W %x %y %s}
set myMenuFlag 0
set myMenuMotion 0
# ::tk::MenuNextEntry --
# 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 ::tk::MenuNextEntry {menu count} {
global ::tk::Priv
if {[$menu index last] eq "none"} {
return
}
set length [expr {[$menu index last]+1}]
set quitAfter $length
set active [$menu index active]
if {$active eq "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 ne "disabled"} {
break
}
}
if {$i == $active} {
return
}
incr i $count
incr quitAfter -1
}
$menu activate $i
::tk::GenerateMenuSelect $menu
if {[$menu type $i] eq "cascade"} {
set cascade [$menu entrycget $i -menu]
if {[$menu cget -type] eq "menubar" && $cascade ne ""} {
# 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
::tk::MenuFirstEntry $cascade
}
}
}
# ::tk::MenuNextMenu --
# 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 ::tk::MenuNextMenu {menu direction} {
global ::tk::Priv
# First handle traversals into and out of cascaded menus.
if {$direction eq "right"} {
set count 1
set parent [winfo parent $menu]
set class [winfo class $parent]
if {[$menu type active] eq "cascade"} {
$menu postcascade active
set m2 [$menu entrycget active -menu]
if {$m2 ne ""} {
::tk::MenuFirstEntry $m2
}
return
} else {
set parent [winfo parent $menu]
while {$parent ne "."} {
if {[winfo class $parent] eq "Menu" && \
[$parent cget -type] eq "menubar"} {
tk_menuSetFocus $parent
::tk::MenuNextEntry $parent 1
return
}
set parent [winfo parent $parent]
}
}
} else {
set count -1
set m2 [winfo parent $menu]
if {[winfo class $m2] eq "Menu"} {
if {[$m2 cget -type] ne "menubar"} {
$menu activate none
::tk::GenerateMenuSelect $menu
tk_menuSetFocus $m2
# This code unposts any posted submenu in the parent.
$m2 postcascade none
#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] eq "Menu"} {
if {[$m2 cget -type] eq "menubar"} {
tk_menuSetFocus $m2
::tk::MenuNextEntry $m2 -1
return
}
}
set w $::tk::Priv(postedMb)
if {$w eq ""} {
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] eq "Menubutton" \
&& [$mb cget -state] ne "disabled" \
&& [$mb cget -menu] ne "" \
&& [[$mb cget -menu] index last] ne "none"} {
break
}
if {$mb eq $w} {
return
}
incr i $count
}
::tk::MbPost $mb
::tk::MenuFirstEntry [$mb cget -menu]
}
# ::tk::MenuFirstEntry --
# 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 ::tk::PostOverPoint) 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 ::tk::MenuFirstEntry menu {
if {$menu eq ""} {
return
}
tk_menuSetFocus $menu
if {[$menu index active] ne "none"} {
return
}
set last [$menu index last]
if {$last eq "none"} {
return
}
for {set i 0} {$i <= $last} {incr i} {
if {([catch {set state [$menu entrycget $i -state]}] == 0) \
&& $state ne "disabled"} {
#~$menu activate $i
#~::tk::GenerateMenuSelect $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 {[$menu type $i] eq "cascade" && \
[$menu cget -type] eq "menubar"} {
set cascade [$menu entrycget $i -menu]
if {$cascade ne ""} {
$menu postcascade $i
::tk::MenuFirstEntry $cascade
}
}
return
}
}
}
# ::tk::MenuMotion --
# 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 ::tk::MenuMotion {menu x y state} {
global ::tk::Priv
if {$menu eq $::tk::Priv(window)} {
if {[$menu cget -type] eq "menubar"} {
if {[info exists ::tk::Priv(focus)] && $menu ne $::tk::Priv(focus)} {
$menu activate @$x,$y
::tk::GenerateMenuSelect $menu
}
} else {
$menu activate @$x,$y
::tk::GenerateMenuSelect $menu
}
}
#debugmsg plugins "MENU: $menu $::tk::Priv(activeMenu) $::tk::Priv(activeItem) $::tk::Priv(focus)"
if {([$menu cget -type] ne "menubar") || \
([info exist ::tk::Priv(focus)] && ($::tk::Priv(focus) ne "") && ($::tk::Priv(activeItem) != "none"))} {
myMenuPostCascade $menu
}
}
# ::tk::MenuButtonDown --
# 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 ::tk::MenuButtonDown menu {
variable ::tk::Priv
global tcl_platform
if {![winfo viewable $menu]} {
return
}
$menu postcascade active
if {$Priv(postedMb) ne "" && [winfo viewable $Priv(postedMb)]} {
grab -global $Priv(postedMb)
} else {
while {[$menu cget -type] eq "normal" \
&& [winfo class [winfo parent $menu]] eq "Menu" \
&& [winfo ismapped [winfo parent $menu]]} {
set menu [winfo parent $menu]
}
if {$Priv(menuBar) eq {}} {
set Priv(menuBar) $menu
set Priv(cursor) [$menu cget -cursor]
$menu configure -cursor arrow
} else {
$menu activate none
#MenuUnpost $menu
}
# 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 ne [grab current $menu]} {
SaveGrabInfo $menu
}
# Must re-grab even if the grab window hasn't changed, in order
# to release the implicit grab from the button press.
if {[tk windowingsystem] eq "x11"} {
grab -global $menu
}
}
}
set myPriv(id) ""
set myPriv(delay) 170
set myPriv(activeMenu) ""
set myPriv(activeItem) ""
proc myMenuPostCascade {menu} {
global myPriv
if {$myPriv(id) ne ""} {
if {($myPriv(activeMenu) == $menu) && ($myPriv(activeItem) == [$menu index active])} {
return
} else {
after cancel $myPriv(id)
}
}
if {[$menu cget -type] eq "menubar"} {
$menu postcascade active
} else {
set myPriv(activeMenu) $menu
set myPriv(activeItem) [$menu index active]
set myPriv(id) [after $myPriv(delay) "$menu postcascade active"]
}
}
}