From 7540b82fe0542de05038049569f2b6656338dd18 Mon Sep 17 00:00:00 2001
From: patthoyts <patthoyts@users.sourceforge.net>
Date: Sat, 9 Jan 2010 00:43:46 +0000
Subject: TIP 360: Make Tk menu activation follow mouse movement.

This patch makes Tk menus on unix follow mouse motion in the same
way Windows and GNOME menus follow the mouse. Once a menubar dropdown
has been activated, moving the mouse to another menubar button or
cascade item will activate the dropdown without needing another click.

The previous behaviour can be restored by setting the *Menu.clickToFocus
option true or by calling 'tk::classic::restore menu' if this is preferred.

Signed-off-by: Pat Thoyts <patthoyts@users.sourceforge.net>
---
 ChangeLog            |  5 +++++
 library/menu.tcl     | 25 +++++++++++++++++++++----
 library/obsolete.tcl |  3 ++-
 3 files changed, 28 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b6f8e97..77c388a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2010-01-09  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* library/menu.tcl:      [TIP 360] Make Tk menu activation
+	* library/obsolete.tcl:  follow mouse movements.
+
 2010-01-08  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
 	* doc/photo.n: [Bug 2927569] Multiple edits have peverted the
diff --git a/library/menu.tcl b/library/menu.tcl
index b80af90..751d556 100644
--- a/library/menu.tcl
+++ b/library/menu.tcl
@@ -4,7 +4,7 @@
 # It also implements keyboard traversal of menus and implements a few
 # other utility procedures related to menus.
 #
-# RCS: @(#) $Id: menu.tcl,v 1.32 2009/04/10 16:08:42 das Exp $
+# RCS: @(#) $Id: menu.tcl,v 1.33 2010/01/09 00:43:46 patthoyts Exp $
 #
 # Copyright (c) 1992-1994 The Regents of the University of California.
 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
@@ -406,6 +406,9 @@ proc ::tk::MenuUnpost menu {
     # Unpost menu(s) and restore some stuff that's dependent on
     # what was posted.
 
+    after cancel [array get Priv menuActivatedTimer]
+    unset -nocomplain Priv(menuActivated)
+
     catch {
 	if {$mb ne ""} {
 	    set menu [$mb cget -menu]
@@ -547,6 +550,7 @@ proc ::tk::MbButtonUp w {
 proc ::tk::MenuMotion {menu x y state} {
     variable ::tk::Priv
     if {$menu eq $Priv(window)} {
+        set activeindex [$menu index active]
 	if {[$menu cget -type] eq "menubar"} {
 	    if {[info exists Priv(focus)] && $menu ne $Priv(focus)} {
 		$menu activate @$x,$y
@@ -556,9 +560,18 @@ proc ::tk::MenuMotion {menu x y state} {
 	    $menu activate @$x,$y
 	    GenerateMenuSelect $menu
 	}
-    }
-    if {($state & 0x1f00) != 0} {
-	$menu postcascade active
+        set index [$menu index @$x,$y]
+        if {[info exists Priv(menuActivated)] \
+                && $index ne "none" \
+                && $index ne $activeindex \
+                && [$menu type $index] eq "cascade"} {
+            set mode [option get $menu clickToFocus ClickToFocus]
+            if {$mode eq "" || ([string is boolean $mode] && !$mode)} {
+                set delay [expr {[$menu cget -type] eq "menubar"? 0 : 50}]
+                set Priv(menuActivatedTimer) \
+                    [after $delay [list $menu postcascade active]]
+            }
+        }
     }
 }
 
@@ -600,6 +613,9 @@ proc ::tk::MenuButtonDown menu {
 		set Priv(cursor) [$menu cget -cursor]
 		$menu configure -cursor arrow
 	    }
+	    if {[$menu type active] eq "cascade"} {
+		set Priv(menuActivated) 1
+	    }
         }
 
 	# Don't update grab information if the grab window isn't changing.
@@ -1311,6 +1327,7 @@ proc ::tk_popup {menu x y {entry {}}} {
         tk::SaveGrabInfo $menu
 	grab -global $menu
 	set Priv(popup) $menu
+	set Priv(menuActivated) 1
 	tk_menuSetFocus $menu
     }
 }
diff --git a/library/obsolete.tcl b/library/obsolete.tcl
index 327fc02..fe19367 100644
--- a/library/obsolete.tcl
+++ b/library/obsolete.tcl
@@ -3,7 +3,7 @@
 # This file contains obsolete procedures that people really shouldn't
 # be using anymore, but which are kept around for backward compatibility.
 #
-# RCS: @(#) $Id: obsolete.tcl,v 1.4 2007/12/13 15:26:27 dgp Exp $
+# RCS: @(#) $Id: obsolete.tcl,v 1.5 2010/01/09 00:43:46 patthoyts Exp $
 #
 # Copyright (c) 1994 The Regents of the University of California.
 # Copyright (c) 1994 Sun Microsystems, Inc.
@@ -117,6 +117,7 @@ proc ::tk::classic::restore_menu {args} {
     if {[tk windowingsystem] eq "x11"} {
 	option add *Menu.activeBorderWidth	2 $prio; # 1
 	option add *Menu.borderWidth		2 $prio; # 1
+        option add *Menu.clickToFocus		true $prio
     }
     if {[tk windowingsystem] ne "aqua"} {
 	option add *Menu.font		"TkDefaultFont" $prio; # "TkMenuFont"
-- 
cgit v0.12