TIP#286 implementation. [Patch 1152376]

4 files changed, 109 insertions, 43 deletions

diff --git a/ChangeLog b/ChangeLog
index 6cd7250..79ab9f1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2006-12-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	TIP #286 IMPLEMENTATION
+
+	* generic/tkMenu.c (MenuWidgetObjCmd, MenuDoXPosition): 
+	* doc/menu.n, tests/menu.test: Added an [$menu xposition] subcommand
+	which is useful in menubars and when menus use multiple columns. Many
+	thanks to Schelte Bron for the implementation.
+
 2006-12-01  Kevin Kenny  <kennykb@acm.org>
 
 	TIP #300 IMPLEMENTATION
diff --git a/doc/menu.n b/doc/menu.n
index 96095e9..ea6ecb0 100644
--- a/doc/menu.n
+++ b/doc/menu.n
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: menu.n,v 1.12 2005/04/06 21:11:54 dkf Exp $
+'\" RCS: @(#) $Id: menu.n,v 1.13 2006/12/04 15:16:31 dkf Exp $
 '\" 
 .so man.macros
 .TH menu n 4.1 Tk "Tk Built-In Commands"
@@ -118,21 +118,19 @@ Whenever a menu's active entry is changed, a <<MenuSelect>> virtual
 event is send to the menu. The active item can then be queried from
 the menu, and an action can be taken, such as setting
 context-sensitive help text for the entry.
-
-.SH "COMMAND ENTRIES"
+.SH "TYPES OF ENTRIES"
+.SS "COMMAND ENTRIES"
 .PP
 The most common kind of menu entry is a command entry, which
 behaves much like a button widget.  When a command entry is
 invoked, a Tcl command is executed.  The Tcl
 command is specified with the \fB\-command\fR option.
-
-.SH "SEPARATOR ENTRIES"
+.SS "SEPARATOR ENTRIES"
 .PP
 A separator is an entry that is displayed as a horizontal dividing
 line.  A separator may not be activated or invoked, and it has
 no behavior other than its display appearance.
-
-.SH "CHECKBUTTON ENTRIES"
+.SS "CHECKBUTTON ENTRIES"
 .PP
 A checkbutton menu entry behaves much like a checkbutton widget.
 When it is invoked it toggles back and forth between the selected
@@ -149,8 +147,7 @@ the menu.  If a \fB\-command\fR option is specified for a checkbutton
 entry, then its value is evaluated as a Tcl command each time the entry
 is invoked;  this happens after toggling the entry's
 selected state.
-
-.SH "RADIOBUTTON ENTRIES"
+.SS "RADIOBUTTON ENTRIES"
 .PP
 A radiobutton menu entry behaves much like a radiobutton widget.
 Radiobutton entries are organized in groups of which only one
@@ -173,8 +170,7 @@ otherwise the indicator's center is displayed in the background color for
 the menu.  If a \fB\-command\fR option is specified for a radiobutton
 entry, then its value is evaluated as a Tcl command each time the entry
 is invoked;  this happens after selecting the entry.
-
-.SH "CASCADE ENTRIES"
+.SS "CASCADE ENTRIES"
 .PP
 A cascade entry is one with an associated menu (determined
 by the \fB\-menu\fR option).  Cascade entries allow the construction
@@ -205,8 +201,7 @@ menu.
 If a \fB\-command\fR option is specified for a cascade entry then it is
 evaluated as a Tcl command whenever the entry is invoked. This is not
 supported on Windows.
-
-.SH "TEAR-OFF ENTRIES"
+.SS "TEAR-OFF ENTRIES"
 .PP
 A tear-off entry appears at the top of the menu if enabled with the
 \fBtearOff\fR option.  It is not like other menu entries in that
@@ -216,7 +211,6 @@ When a tear-off entry is created it appears as a dashed line at
 the top of the menu.  Under the default bindings, invoking the
 tear-off entry causes a torn-off copy to be made of the menu and
 all of its submenus.
-
 .SH "MENUBARS"
 .PP
 Any menu can be set as a menubar for a toplevel window (see
@@ -233,8 +227,7 @@ example of this concerns the handling of checkbuttons and radiobuttons
 within the menu.  While it is permitted to put these menu elements on
 menubars, they may not be drawn with indicators on some platforms, due
 to system restrictions.
-
-.SH "SPECIAL MENUS IN MENUBARS"
+.SS "SPECIAL MENUS IN MENUBARS"
 .PP
 Certain menus in a menubar will be treated specially.  On the Macintosh,
 access to the special Apple and Help menus is provided. On Windows,
@@ -274,7 +267,6 @@ system menu.
 .PP
 When Tk see a Help menu on X Windows, the menu is moved to be last in
 the menubar and is right justified.
-
 .SH "CLONES"
 .PP
 When a menu is set as a menubar for a toplevel window, or when a menu
@@ -285,7 +277,6 @@ clone. Additionally, any cascades that are pointed to are also cloned
 so that menu traversal will work right. Clones are destroyed when
 either the tearoff or menubar goes away, or when the original menu is
 destroyed. 
-
 .SH "WIDGET COMMAND"
 .PP
 The \fBmenu\fR command creates a new Tcl command whose
@@ -637,10 +628,15 @@ lower-level cascaded menu is posted, unpost that menu.  Returns an
 empty string. This subcommand does not work on Windows and the
 Macintosh, as those platforms have their own way of unposting menus.
 .TP
+\fIpathName \fBxposition \fIindex\fR
+.VS 8.5
+Returns a decimal string giving the x-coordinate within the menu
+window of the leftmost pixel in the entry specified by \fIindex\fR.
+.VE 8.5
+.TP
 \fIpathName \fByposition \fIindex\fR
 Returns a decimal string giving the y-coordinate within the menu
 window of the topmost pixel in the entry specified by \fIindex\fR.
-
 .SH "MENU CONFIGURATIONS"
 .PP
 The default bindings support four different ways of using menus:
@@ -683,7 +679,6 @@ the top of an existing menu.  The default bindings will create a new menu
 that is a copy of the original menu and leave it permanently
 posted as a top-level window.  The torn-off menu behaves just
 the same as the original menu.
-
 .SH "DEFAULT BINDINGS"
 .PP
 Tk automatically creates class bindings for menus that give them
@@ -744,12 +739,12 @@ argument, which is a menu widget.
 .PP
 The behavior of menus can be changed by defining new bindings for
 individual widgets or by redefining the class bindings.
-
 .SH BUGS
 .PP
 At present it isn't possible to use the
 option database to specify values for the options to individual
 entries.
-
 .SH KEYWORDS
 menu, widget
+.SH "SEE ALSO"
+bind(n), menubutton(n), toplevel(n)
diff --git a/generic/tkMenu.c b/generic/tkMenu.c
index e87b072..6dd2fc2 100644
--- a/generic/tkMenu.c
+++ b/generic/tkMenu.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkMenu.c,v 1.36 2006/05/25 23:50:16 hobbs Exp $
+ * RCS: @(#) $Id: tkMenu.c,v 1.37 2006/12/04 15:16:30 dkf Exp $
  */
 
 /*
@@ -313,13 +313,13 @@ static Tk_OptionSpec tkMenuConfigSpecs[] = {
 static CONST char *menuOptions[] = {
     "activate", "add", "cget", "clone", "configure", "delete", "entrycget",
     "entryconfigure", "index", "insert", "invoke", "post", "postcascade",
-    "type", "unpost", "yposition", NULL
+    "type", "unpost", "xposition", "yposition", NULL
 };
 enum options {
     MENU_ACTIVATE, MENU_ADD, MENU_CGET, MENU_CLONE, MENU_CONFIGURE,
     MENU_DELETE, MENU_ENTRYCGET, MENU_ENTRYCONFIGURE, MENU_INDEX,
     MENU_INSERT, MENU_INVOKE, MENU_POST, MENU_POSTCASCADE, MENU_TYPE,
-    MENU_UNPOST, MENU_YPOSITION
+    MENU_UNPOST, MENU_XPOSITION, MENU_YPOSITION
 };
 
 /*
@@ -345,6 +345,8 @@ static int		GetIndexFromCoords(Tcl_Interp *interp, TkMenu *menuPtr,
 			    char *string, int *indexPtr);
 static int		MenuDoYPosition(Tcl_Interp *interp,
 			    TkMenu *menuPtr, Tcl_Obj *objPtr);
+static int		MenuDoXPosition(Tcl_Interp *interp,
+			    TkMenu *menuPtr, Tcl_Obj *objPtr);
 static int		MenuAddOrInsert(Tcl_Interp *interp,
 			    TkMenu *menuPtr, Tcl_Obj *indexPtr, int objc,
 			    Tcl_Obj *CONST objv[]);
@@ -683,7 +685,7 @@ MenuWidgetObjCmd(
 	int index;
 
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "activate index");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index");
 	    goto error;
 	}
 	if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) {
@@ -701,7 +703,7 @@ MenuWidgetObjCmd(
     }
     case MENU_ADD:
 	if (objc < 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "add type ?options?");
+	    Tcl_WrongNumArgs(interp, 2, objv, "type ?options?");
 	    goto error;
 	}
 
@@ -713,7 +715,7 @@ MenuWidgetObjCmd(
 	Tcl_Obj *resultPtr;
 
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "cget option");
+	    Tcl_WrongNumArgs(interp, 2, objv, "option");
 	    goto error;
 	}
 	resultPtr = Tk_GetOptionValue(interp, (char *) menuPtr,
@@ -727,7 +729,7 @@ MenuWidgetObjCmd(
     }
     case MENU_CLONE:
 	if ((objc < 3) || (objc > 4)) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "clone newMenuName ?menuType?");
+	    Tcl_WrongNumArgs(interp, 2, objv, "newMenuName ?menuType?");
 	    goto error;
 	}
 	result = CloneMenu(menuPtr, objv[2], (objc == 3) ? NULL : objv[3]);
@@ -767,7 +769,7 @@ MenuWidgetObjCmd(
 	int first, last;
 
 	if ((objc != 3) && (objc != 4)) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "delete first ?last?");
+	    Tcl_WrongNumArgs(interp, 2, objv, "first ?last?");
 	    goto error;
 	}
 	if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &first) != TCL_OK) {
@@ -798,7 +800,7 @@ MenuWidgetObjCmd(
 	Tcl_Obj *resultPtr;
 
 	if (objc != 4) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "entrycget index option");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index option");
 	    goto error;
 	}
 	if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) {
@@ -823,8 +825,7 @@ MenuWidgetObjCmd(
 	Tcl_Obj *resultPtr;
 
 	if (objc < 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv,
-		    "entryconfigure index ?option value ...?");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index ?option value ...?");
 	    goto error;
 	}
 	if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) {
@@ -864,7 +865,7 @@ MenuWidgetObjCmd(
 	int index;
 
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "index string");
+	    Tcl_WrongNumArgs(interp, 2, objv, "string");
 	    goto error;
 	}
 	if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) {
@@ -879,7 +880,7 @@ MenuWidgetObjCmd(
     }
     case MENU_INSERT:
 	if (objc < 4) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "insert index type ?options?");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index type ?options?");
 	    goto error;
 	}
 	if (MenuAddOrInsert(interp,menuPtr,objv[2],objc-3,objv+3) != TCL_OK) {
@@ -890,7 +891,7 @@ MenuWidgetObjCmd(
 	int index;
 
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "invoke index");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index");
 	    goto error;
 	}
 	if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) {
@@ -906,7 +907,7 @@ MenuWidgetObjCmd(
 	int x, y;
 
 	if (objc != 4) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "post x y");
+	    Tcl_WrongNumArgs(interp, 2, objv, "x y");
 	    goto error;
 	}
 	if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK)
@@ -931,7 +932,7 @@ MenuWidgetObjCmd(
 	int index;
 
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "postcascade index");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index");
 	    goto error;
 	}
 
@@ -949,7 +950,7 @@ MenuWidgetObjCmd(
 	int index;
 
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "type index");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index");
 	    goto error;
 	}
 	if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) {
@@ -968,15 +969,22 @@ MenuWidgetObjCmd(
     }
     case MENU_UNPOST:
 	if (objc != 2) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "unpost");
+	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
 	    goto error;
 	}
 	Tk_UnmapWindow(menuPtr->tkwin);
 	result = TkPostSubmenu(interp, menuPtr, NULL);
 	break;
+    case MENU_XPOSITION:
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "index");
+	    goto error;
+	}
+	result = MenuDoXPosition(interp, menuPtr, objv[2]);
+	break;
     case MENU_YPOSITION:
 	if (objc != 3) {
-	    Tcl_WrongNumArgs(interp, 1, objv, "yposition index");
+	    Tcl_WrongNumArgs(interp, 2, objv, "index");
 	    goto error;
 	}
 	result = MenuDoYPosition(interp, menuPtr, objv[2]);
@@ -2813,6 +2821,43 @@ CloneMenu(
 /*
  *----------------------------------------------------------------------
  *
+ * MenuDoXPosition --
+ *
+ *	Given arguments from an option command line, returns the X position.
+ *
+ * Results:
+ *	Returns TCL_OK or TCL_Error
+ *
+ * Side effects:
+ *	xPosition is set to the X-position of the menu entry.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+MenuDoXPosition(
+    Tcl_Interp *interp,
+    TkMenu *menuPtr,
+    Tcl_Obj *objPtr)
+{
+    int index;
+
+    TkRecomputeMenu(menuPtr);
+    if (TkGetMenuIndex(interp, menuPtr, objPtr, 0, &index) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    Tcl_ResetResult(interp);
+    if (index < 0) {
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+    } else {
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(menuPtr->entries[index]->x));
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * MenuDoYPosition --
  *
  *	Given arguments from an option command line, returns the Y position.
diff --git a/tests/menu.test b/tests/menu.test
index 24e57cc..f67fcbe 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -5,7 +5,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: menu.test,v 1.19 2006/11/24 18:11:32 hobbs Exp $
+# RCS: @(#) $Id: menu.test,v 1.20 2006/12/04 15:16:31 dkf Exp $
 
 package require tcltest 2.1
 eval tcltest::configure $argv
@@ -897,7 +897,7 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} {
     catch {destroy .m1}
     menu .m1
     list [catch {.m1 foo} msg] $msg [destroy .m1]
-} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, or yposition} {}}
+} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} {}}
 test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} {
     set t .t
     set m1 .t.m1
@@ -917,6 +917,23 @@ test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} {
     destroy $t;
     set l;
 } {1 1}
+test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup {
+    catch {destroy .m1}
+    menu .m1
+} -body {
+    .m1 xposition
+} -cleanup {
+    destroy .m1
+} -returnCodes error -result {wrong # args: should be ".m1 xposition index"}
+test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup {
+    catch {destroy .m1}
+    menu .m1
+} -body {
+    .m1 xposition 1
+    subst {} ;# just checking that the xposition does not produce an error...
+} -cleanup {
+    destroy .m1
+} -result {}
 
 test menu-4.1 {TkInvokeMenu: disabled} {
     catch {destroy .m1}