TIP #533 (Extension of the menu post command) implementation was accepted by TCT vote. This allows fixing of bug [70e531918e]: geometry issues with menubuttons on macOS.

1 files changed, 140 insertions, 108 deletions

diff --git a/library/menu.tcl b/library/menu.tcl
index ba66b92..8d06868 100644
--- a/library/menu.tcl
+++ b/library/menu.tcl
@@ -234,6 +234,7 @@ proc ::tk::MbLeave w {
     }
 }
 
+
 # ::tk::MbPost --
 # Given a menubutton, this procedure does all the work of posting
 # its associated menu and unposting any other menu that is currently
@@ -282,101 +283,17 @@ proc ::tk::MbPost {w {x {}} {y {}}} {
     set Priv(focus) [focus]
     $menu activate none
     GenerateMenuSelect $menu
-
-    # If this looks like an option menubutton then post the menu so
-    # that the current entry is on top of the mouse.  Otherwise post
-    # the menu just below the menubutton, as for a pull-down.
-
     update idletasks
-    if {[catch {
-	switch [$w cget -direction] {
-	    above {
-		set x [winfo rootx $w]
-		set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
-		# if we go offscreen to the top, show as 'below'
-		if {$y < [winfo vrooty $w]} {
-		    set y [expr {[winfo vrooty $w] + [winfo rooty $w] + [winfo reqheight $w]}]
-		}
-		PostOverPoint $menu $x $y
-	    }
-	    below {
-		set x [winfo rootx $w]
-		set y [expr {[winfo rooty $w] + [winfo height $w]}]
-		# if we go offscreen to the bottom, show as 'above'
-		set mh [winfo reqheight $menu]
-		if {($y + $mh) > ([winfo vrooty $w] + [winfo vrootheight $w])} {
-		    set y [expr {[winfo vrooty $w] + [winfo vrootheight $w] + [winfo rooty $w] - $mh}]
-		}
-		PostOverPoint $menu $x $y
-	    }
-	    left {
-		set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
-		set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
-		set entry [MenuFindName $menu [$w cget -text]]
-		if {$entry eq ""} {
-                    set entry 0
-		}
-		if {[$w cget -indicatoron]} {
-		    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}]
-		    }
-		}
-		PostOverPoint $menu $x $y
-		if {$entry ne "" \
-			&& [$menu entrycget $entry -state] ne "disabled"} {
-		    $menu activate $entry
-		    GenerateMenuSelect $menu
-		}
-	    }
-	    right {
-		set x [expr {[winfo rootx $w] + [winfo width $w]}]
-		set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
-		set entry [MenuFindName $menu [$w cget -text]]
-		if {$entry eq ""} {
-                    set entry 0
-		}
-		if {[$w cget -indicatoron]} {
-		    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}]
-		    }
-		}
-		PostOverPoint $menu $x $y
-		if {$entry ne "" \
-			&& [$menu entrycget $entry -state] ne "disabled"} {
-		    $menu activate $entry
-		    GenerateMenuSelect $menu
-		}
-	    }
-	    default {
-		if {[$w cget -indicatoron]} {
-		    if {$y eq ""} {
-			set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
-			set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
-		    }
-	            PostOverPoint $menu $x $y [MenuFindName $menu [$w cget -text]]
-		} else {
-		    PostOverPoint $menu [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
-		}
-	    }
-	}
-    } msg opt]} {
+
+    if {[catch {PostMenubuttonMenu $w $menu} msg opt]} {
 	# Error posting menu (e.g. bogus -postcommand). Unpost it and
 	# reflect the error.
-
 	MenuUnpost {}
 	return -options $opt $msg
     }
 
     set Priv(tearoff) $tearoff
-    if {$tearoff != 0} {
+    if {$tearoff != 0 && [tk windowingsystem] ne "aqua"} {
 	focus $menu
 	if {[winfo viewable $w]} {
 	    SaveGrabInfo $w
@@ -576,11 +493,13 @@ proc ::tk::MenuMotion {menu x y state} {
             if {[string is false $mode]} {
                 set delay [expr {[$menu cget -type] eq "menubar" ? 0 : 50}]
                 if {[$menu type $index] eq "cascade"} {
+                    # Catch these postcascade commands since the menu could be
+                    # destroyed before they run.
                     set Priv(menuActivatedTimer) \
-                        [after $delay [list $menu postcascade active]]
+                        [after $delay "catch {$menu postcascade active}"]
                 } else {
                     set Priv(menuDeactivatedTimer) \
-                        [after $delay [list $menu postcascade none]]
+                        [after $delay "catch {$menu postcascade none}"]
                 }
             }
         }
@@ -1208,10 +1127,118 @@ proc ::tk::MenuFindName {menu s} {
     return ""
 }
 
+# ::tk::PostMenubuttonMenu --
+#
+# Given a menubutton and a menu, this procedure posts the menu at the
+# appropriate location.  If the menubutton looks like an option
+# menubutton, meaning that the indicator is on and the direction is
+# neither above nor below, then the menu is posted so that the current
+# entry is vertically aligned with the menubutton.  On the Mac this
+# will expose a small amount of the blue indicator on the right hand
+# side.  On other platforms the entry is centered over the button.
+
+if {[tk windowingsystem] eq "aqua"} {
+    proc ::tk::PostMenubuttonMenu {button menu} {
+	set entry ""
+	if {[$button cget -indicatoron]} {
+	    set entry [MenuFindName $menu [$button cget -text]]
+	    if {$entry eq ""} {
+		set entry 0
+	    }
+	}
+	set x [winfo rootx $button]
+	set y [expr {2 + [winfo rooty $button]}]
+	switch [$button cget -direction] {
+	    above {
+		set entry ""
+		incr y [expr {4 - [winfo reqheight $menu]}]
+	    }
+	    below {
+		set entry ""
+		incr y [expr {2 + [winfo height $button]}]
+	    }
+	    left {
+		incr x [expr {-[winfo reqwidth $menu]}]
+	    }
+	    right {
+		incr x [winfo width $button]
+	    }
+	    default {
+		incr x [expr {[winfo width $button] - [winfo reqwidth $menu] - 5}]
+	    }
+	}
+	PostOverPoint $menu $x $y $entry
+    }
+} else {
+    proc ::tk::PostMenubuttonMenu {button menu} {
+	set entry ""
+	if {[$button cget -indicatoron]} {
+	    set entry [MenuFindName $menu [$button cget -text]]
+	    if {$entry eq ""} {
+		set entry 0
+	    }
+	}
+	if {$entry ne ""} {
+	    if {$entry == [$menu index last]} {
+		set entryHeight [expr {[winfo reqheight $menu] \
+				       - [$menu yposition $entry]}]
+	    } else {
+		set entryHeight [expr {[$menu yposition [expr {$entry+1}]] \
+					- [$menu yposition $entry]}]
+	    }
+	}
+	set x [winfo rootx $button]
+	set y [winfo rooty $button]
+	switch [$button cget -direction] {
+	    above {
+		incr y [expr {-[winfo reqheight $menu]}]
+		# if we go offscreen to the top, show as 'below'
+		if {$y < [winfo vrooty $button]} {
+		    set y [expr {[winfo vrooty $button] + [winfo rooty $button]\
+                           + [winfo reqheight $button]}]
+		}
+		set entry {}
+	    }
+	    below {
+		incr y [winfo height $button]
+		# if we go offscreen to the bottom, show as 'above'
+		set mh [winfo reqheight $menu]
+		if {($y + $mh) > ([winfo vrooty $button] + [winfo vrootheight $button])} {
+		    set y [expr {[winfo vrooty $button] + [winfo vrootheight $button] \
+			   + [winfo rooty $button] - $mh}]
+		}
+		set entry {}
+	    }
+	    left {
+		# It is not clear why this is needed.
+		if {[tk windowingsystem] eq "win32"} {
+		    incr x [expr {-4 - [winfo reqwidth $button] / 2}]
+		}
+		incr x [expr {- [winfo reqwidth $menu]}]
+	    }
+	    right {
+		incr x [expr {[winfo width $button]}]
+	    }
+	    default {
+		if {[$button cget -indicatoron]} {
+		    incr x [expr {([winfo width $button] - \
+				   [winfo reqwidth $menu])/ 2}]
+		} else {
+		    incr y [winfo height $button]
+		}
+	    }
+	}
+	PostOverPoint $menu $x $y $entry
+    }
+}
+
 # ::tk::PostOverPoint --
-# 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.
+#
+# This procedure posts a menu on the screen so that a given entry in
+# the menu is positioned with its upper left corner at a given point
+# in the root window.  The procedure also activates that entry.  If no
+# entry is specified the upper left corner of the entire menu is
+# placed at the point.
 #
 # Arguments:
 # menu -		Menu to post.
@@ -1220,19 +1247,24 @@ proc ::tk::MenuFindName {menu s} {
 #			If omitted or specified as {}, then the menu's
 #			upper-left corner goes at (x,y).
 
-proc ::tk::PostOverPoint {menu x y {entry {}}}  {
-    if {$entry ne ""} {
-	if {$entry == [$menu index last]} {
-	    incr y [expr {-([$menu yposition $entry] \
-		    + [winfo reqheight $menu])/2}]
+if {[tk windowingsystem] ne "win32"} {
+    proc ::tk::PostOverPoint {menu x y {entry {}}}  {
+	if {$entry ne ""} {
+	    $menu post $x $y $entry
+	    if {[$menu entrycget $entry -state] ne "disabled"} {
+		$menu activate $entry
+		GenerateMenuSelect $menu
+	    }
 	} else {
-	    incr y [expr {-([$menu yposition $entry] \
-		    + [$menu yposition [expr {$entry+1}]])/2}]
+	    $menu post $x $y
 	}
-	incr x [expr {-[winfo reqwidth $menu]/2}]
+	return
     }
-
-    if {[tk windowingsystem] eq "win32"} {
+} else {
+    proc ::tk::PostOverPoint {menu x y {entry {}}}  {
+	if {$entry ne ""} {
+	    incr y [expr {-[$menu yposition $entry]}]
+	}
 	# osVersion is not available in safe interps
 	set ver 5
 	if {[info exists ::tcl_platform(osVersion)]} {
@@ -1248,7 +1280,7 @@ proc ::tk::PostOverPoint {menu x y {entry {}}}  {
 	# manager provided with Vista and Windows 7.
 	if {$ver < 6} {
 	    set yoffset [expr {[winfo screenheight $menu] \
-		    - $y - [winfo reqheight $menu] - 10}]
+				   - $y - [winfo reqheight $menu] - 10}]
 	    if {$yoffset < [winfo vrooty $menu]} {
 		# The bottom of the menu is offscreen, so adjust upwards
 		incr y [expr {$yoffset - [winfo vrooty $menu]}]
@@ -1260,11 +1292,11 @@ proc ::tk::PostOverPoint {menu x y {entry {}}}  {
 		set y [winfo vrooty $menu]
 	    }
 	}
-    }
-    $menu post $x $y
-    if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
-	$menu activate $entry
-	GenerateMenuSelect $menu
+	$menu post $x $y
+	if {$entry ne "" && [$menu entrycget $entry -state] ne "disabled"} {
+	    $menu activate $entry
+	    GenerateMenuSelect $menu
+	}
     }
 }