Implement TIP 658

5 files changed, 138 insertions, 43 deletions

diff --git a/doc/menu.n b/doc/menu.n
index 42d1775..a7c52ab 100644
--- a/doc/menu.n
+++ b/doc/menu.n
@@ -356,6 +356,10 @@ Specifies the entry numerically, where 0 corresponds
 to the top-most entry of the menu, 1 to the entry below it, and
 so on.
 .TP 12
+\fIid\fR
+.
+Indicates the entry with the specified id.
+.TP 12
 \fIpattern\fR
 .
 If the index does not satisfy one of the above forms then this
@@ -378,15 +382,18 @@ is specified as \fB{}\fR or \fBnone\fR, or if the specified entry is
 disabled, then the menu ends up with no active entry.
 Returns an empty string.
 .TP
-\fIpathName \fBadd \fItype \fR?\fIoption value option value ...\fR?
+\fIpathName \fBadd \fItype \fR?\fIid\fR? ?\fIoption value option value ...\fR?
 .
 Add a new entry to the bottom of the menu.  The new entry's type
 is given by \fItype\fR and must be one of \fBcascade\fR,
 \fBcheckbutton\fR, \fBcommand\fR, \fBradiobutton\fR, or \fBseparator\fR,
-or a unique abbreviation of one of the above.  If additional arguments
-are present, they specify the options listed in the \fBMENU ENTRY OPTIONS\fR
-section below.
-The \fBadd\fR widget command returns an empty string.
+or a unique abbreviation of one of the above.
+If the \fIid\fR argument is specified, it is used as the entry identifier;
+\fIid\fR must not already exist in the menu. Otherwise, a new unique
+identifier is generated.
+If additional arguments are present, they specify the options listed in the
+\fBMENU ENTRY OPTIONS\fR section below.
+The \fBadd\fR widget command returns the id of the new entry.
 .TP
 \fIpathName \fBcget \fIoption\fR
 .
@@ -447,19 +454,28 @@ If no \fIoptions\fR are specified, returns a list describing
 the current options for entry \fIindex\fR (see \fBTk_ConfigureInfo\fR for
 information on the format of this list).
 .TP
+\fIpathName \fBid \fIindex\fR
+.
+Returns the id of the menu entry given by \fIindex\fR.
+This is the identifier that was assigned to the entry when it was created
+using the \fBadd\fR or \fBinsert\fR widget command.
+Returns an empty string for the tear-off entry, or if \fIindex\fR is
+equivalent to \fB{}\fR.
+.TP
 \fIpathName \fBindex \fIindex\fR
 .
 Returns the numerical index corresponding to \fIindex\fR, or
 \fB{}\fR if \fIindex\fR was specified as \fB{}\fR or \fBnone\fR.
 .TP
-\fIpathName \fBinsert \fIindex type \fR?\fIoption value option value ...\fR?
+\fIpathName \fBinsert \fIindex type \fR?\fIid\fR? ?\fIoption value option value ...\fR?
 .
 Same as the \fBadd\fR widget command except that it inserts the new
 entry just before the entry given by \fIindex\fR, instead of appending
-to the end of the menu.  The \fItype\fR, \fIoption\fR, and \fIvalue\fR
-arguments have the same interpretation as for the \fBadd\fR widget
-command.  It is not possible to insert new menu entries before the
+to the end of the menu.  The \fItype\fR, \fIid\fR, \fIoption\fR, and
+\fIvalue\fR arguments have the same interpretation as for the \fBadd\fR
+widget command.  It is not possible to insert new menu entries before the
 tear-off entry, if the menu has one.
+The \fBinsert\fR widget command returns the id of the new entry.
 .TP
 \fIpathName \fBinvoke \fIindex\fR
 .
diff --git a/generic/tkMenu.c b/generic/tkMenu.c
index c5d2bf5..69ef6da 100644
--- a/generic/tkMenu.c
+++ b/generic/tkMenu.c
@@ -306,12 +306,12 @@ static const Tk_OptionSpec tkMenuConfigSpecs[] = {
 
 static const char *const menuOptions[] = {
     "activate", "add", "cget", "clone", "configure", "delete", "entrycget",
-    "entryconfigure", "index", "insert", "invoke", "post", "postcascade",
+    "entryconfigure", "id", "index", "insert", "invoke", "post", "postcascade",
     "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_DELETE, MENU_ENTRYCGET, MENU_ENTRYCONFIGURE, MENU_ID, MENU_INDEX,
     MENU_INSERT, MENU_INVOKE, MENU_POST, MENU_POSTCASCADE, MENU_TYPE,
     MENU_UNPOST, MENU_XPOSITION, MENU_YPOSITION
 };
@@ -451,6 +451,8 @@ Tk_MenuObjCmd(
     menuPtr->cursorPtr = NULL;
     menuPtr->mainMenuPtr = menuPtr;
     menuPtr->menuType = UNKNOWN_TYPE;
+    Tcl_InitHashTable(&menuPtr->items, TCL_STRING_KEYS);
+    menuPtr->serial = 0;
     TkMenuInitializeDrawingFields(menuPtr);
 
     Tk_SetClass(menuPtr->tkwin, "Menu");
@@ -821,6 +823,28 @@ MenuWidgetObjCmd(
 	Tcl_Release(mePtr);
 	break;
     }
+    case MENU_ID: {
+	Tcl_Size index;
+	const char *idStr;
+        Tcl_HashEntry *entryPtr;
+
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "index");
+	    goto error;
+	}
+	if (GetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) {
+	    goto error;
+	}
+	if (index == TCL_INDEX_NONE) {
+	    goto done;
+	}
+        entryPtr = menuPtr->entries[index]->entryPtr;
+        if (entryPtr) {
+            idStr = Tcl_GetHashKey(&menuPtr->items, entryPtr);
+            Tcl_SetObjResult(interp, Tcl_NewStringObj(idStr, TCL_INDEX_NONE));
+        }
+	break;
+    }
     case MENU_INDEX: {
 	Tcl_Size index;
 
@@ -1189,6 +1213,7 @@ DestroyMenuInstance(
 	ckfree(menuPtr->entries);
 	menuPtr->entries = NULL;
     }
+    Tcl_DeleteHashTable(&menuPtr->items);
     TkMenuFreeDrawOptions(menuPtr);
     Tk_FreeConfigOptions((char *) menuPtr,
 	    tsdPtr->menuOptionTable, menuPtr->tkwin);
@@ -1455,6 +1480,10 @@ DestroyMenuEntry(
 		TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 		MenuVarProc, mePtr);
     }
+    if (mePtr->entryPtr) {
+        Tcl_DeleteHashEntry(mePtr->entryPtr);
+        mePtr->entryPtr = NULL;
+    }
     TkpDestroyMenuEntry(mePtr);
     TkMenuEntryFreeDrawOptions(mePtr);
     Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable, menuPtr->tkwin);
@@ -2112,6 +2141,7 @@ GetMenuIndex(
 {
     int i;
     const char *string;
+    Tcl_HashEntry *entryPtr;
 
     if (TkGetIntForIndex(objPtr, menuPtr->numEntries - 1, lastOK, indexPtr) == TCL_OK) {
 	/* TCL_INDEX_NONE is only accepted if it does not result from a negative number */
@@ -2153,6 +2183,13 @@ GetMenuIndex(
 	}
     }
 
+    entryPtr = Tcl_FindHashEntry(&menuPtr->items, string);
+    if (entryPtr) {
+        TkMenuEntry *mePtr = Tcl_GetHashValue(entryPtr);
+        *indexPtr = mePtr->index;
+        return TCL_OK;
+    }
+
     for (i = 0; i < (int)menuPtr->numEntries; i++) {
 	Tcl_Obj *labelPtr = menuPtr->entries[i]->labelPtr;
 	const char *label = (labelPtr == NULL) ? NULL : Tcl_GetString(labelPtr);
@@ -2301,6 +2338,7 @@ MenuNewEntry(
 	ckfree(mePtr);
 	return NULL;
     }
+    mePtr->entryPtr = NULL;
     TkMenuInitializeEntryDrawingFields(mePtr);
     if (TkpMenuNewEntry(mePtr) != TCL_OK) {
 	Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable,
@@ -2343,6 +2381,10 @@ MenuAddOrInsert(
     Tcl_Size index;
     TkMenuEntry *mePtr;
     TkMenu *menuListPtr;
+    Tcl_HashEntry *entryPtr;
+    Tcl_Obj *idPtr = NULL;
+    int isNew;
+    int offs;
 
     if (indexPtr != NULL) {
 	if (GetMenuIndex(interp, menuPtr, indexPtr, 1, &index) != TCL_OK) {
@@ -2369,11 +2411,26 @@ MenuAddOrInsert(
 	    sizeof(char *), "menu entry type", 0, &type) != TCL_OK) {
 	return TCL_ERROR;
     }
+    offs = 1;
 
     /*
-     * Now we have to add an entry for every instance related to this menu.
+     * Check for a user supplied id
      */
 
+    if (objc % 2 == 0) {
+        idPtr = objv[offs];
+        if (Tcl_FindHashEntry(&menuPtr->items, Tcl_GetString(idPtr))) {
+            Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+              "Entry %s already exists", Tcl_GetString(idPtr)));
+            Tcl_SetErrorCode(interp, "TK", "MENU", "ENTRY_EXISTS", NULL);
+            return TCL_ERROR;
+        }
+        offs++;
+    }
+
+    /*
+     * Now we have to add an entry for every instance related to this menu.
+     */
     for (menuListPtr = menuPtr->mainMenuPtr; menuListPtr != NULL;
     	    menuListPtr = menuListPtr->nextInstancePtr) {
 
@@ -2381,7 +2438,7 @@ MenuAddOrInsert(
     	if (mePtr == NULL) {
     	    return TCL_ERROR;
     	}
-    	if (ConfigureMenuEntry(mePtr, objc - 1, objv + 1) != TCL_OK) {
+    	if (ConfigureMenuEntry(mePtr, objc - offs, objv + offs) != TCL_OK) {
 	    TkMenu *errorMenuPtr;
 	    Tcl_Size i;
 
@@ -2405,6 +2462,23 @@ MenuAddOrInsert(
     	    return TCL_ERROR;
     	}
 
+        if (idPtr == NULL) {
+            char idbuf[16];
+            /* Generate an id for the new entry on the main menu */
+            do {
+                snprintf(idbuf, sizeof(idbuf), "e%03X", ++menuPtr->serial);
+                entryPtr = 
+                  Tcl_CreateHashEntry(&menuListPtr->items, idbuf, &isNew);
+            } while (!isNew);
+            idPtr = Tcl_NewStringObj(idbuf, TCL_INDEX_NONE);
+        } else {
+            /* Reuse the specified or previously generated id on all clones */
+            entryPtr = Tcl_CreateHashEntry(
+              &menuListPtr->items, Tcl_GetString(idPtr), &isNew);
+        }
+        Tcl_SetHashValue(entryPtr, mePtr);
+        mePtr->entryPtr = entryPtr;
+
     	/*
 	 * If a menu has cascades, then every instance of the menu has to have
 	 * its own parallel cascade structure. So adding an entry to a menu
@@ -2450,6 +2524,8 @@ MenuAddOrInsert(
     	    }
     	}
     }
+
+    Tcl_SetObjResult(interp, idPtr);
     return TCL_OK;
 }
 
diff --git a/generic/tkMenu.h b/generic/tkMenu.h
index 21ca097..f459277 100644
--- a/generic/tkMenu.h
+++ b/generic/tkMenu.h
@@ -183,6 +183,7 @@ typedef struct TkMenuEntry {
     int index;			/* Need to know which index we are. This is
     				 * zero-based. This is the top-left entry of
     				 * the menu. */
+    Tcl_HashEntry *entryPtr;	/* Back-pointer to hash table entry */
 
     /*
      * Bookeeping for main menus and cascade menus.
@@ -379,6 +380,8 @@ typedef struct TkMenu {
 				 * multiple menus get changed during one
 				 * ConfigureMenu call. */
     Tcl_Obj *activeReliefPtr;	/* 3-d effect for active element. */
+    Tcl_HashTable items;	/* Map: id -> entry */
+    int serial;			/* Next item # for autogenerated ids */
 } TkMenu;
 
 /*
diff --git a/library/tearoff.tcl b/library/tearoff.tcl
index 3edae7b..ef51fb3 100644
--- a/library/tearoff.tcl
+++ b/library/tearoff.tcl
@@ -139,7 +139,7 @@ proc ::tk::MenuDup {src dst type} {
 	return
     }
     for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
-	set cmd [list $dst add [$src type $i]]
+	set cmd [list $dst add [$src type $i] [$src id $i]]
 	foreach option [$src entryconfigure $i]  {
 	    lappend cmd [lindex $option 0] [lindex $option 4]
 	}
diff --git a/tests/menu.test b/tests/menu.test
index c18a274..47f9919 100644
--- a/tests/menu.test
+++ b/tests/menu.test
@@ -1310,7 +1310,7 @@ test menu-3.10 {MenuWidgetCmd procedure, "add" option} -setup {
     .m1 add separator
 } -cleanup {
     destroy .m1
-} -result {}
+} -result {e001}
 test menu-3.11 {MenuWidgetCmd procedure, "cget" option} -setup {
     destroy .m1
 } -body {
@@ -1819,7 +1819,7 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} -setup {
     .m1 foo
 } -cleanup {
     destroy .m1
-} -returnCodes error -result {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition}
+} -returnCodes error -result {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, id, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition}
 test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup {
     deleteWindows
 } -body {
@@ -2647,7 +2647,7 @@ test menu-11.15 {ConfigureMenuEntry} -setup {
     list [.m1 add checkbutton -label "test"] [.m1 entrycget 1 -variable]
 } -cleanup {
     deleteWindows
-} -result {{} test}
+} -result {e001 test}
 test menu-11.16 {ConfigureMenuEntry} -setup {
     deleteWindows
 } -body {
@@ -2655,7 +2655,7 @@ test menu-11.16 {ConfigureMenuEntry} -setup {
     .m1 add radiobutton -label "test"
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-11.17 {ConfigureMenuEntry} -setup {
     deleteWindows
 } -body {
@@ -2818,7 +2818,7 @@ test menu-13.4 {TkGetMenuIndex} -setup {
     list [.m1 insert last command -label "test2"] [.m1 entrycget last -label]
 } -cleanup {
     deleteWindows
-} -result {{} test2}
+} -result {e002 test2}
 test menu-13.5 {TkGetMenuIndex} -setup {
     deleteWindows
 } -body {
@@ -2827,7 +2827,7 @@ test menu-13.5 {TkGetMenuIndex} -setup {
     list [.m1 insert end command -label "test2"] [.m1 entrycget end -label]
 } -cleanup {
     deleteWindows
-} -result {{} test2}
+} -result {e002 test2}
 test menu-13.6 {TkGetMenuIndex} -setup {
     deleteWindows
 } -body {
@@ -2924,7 +2924,7 @@ test menu-15.1 {MenuNewEntry} -setup {
     .m1 add command -label "test"
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-15.2 {MenuNewEntry} -setup {
     deleteWindows
 } -body {
@@ -2934,7 +2934,7 @@ test menu-15.2 {MenuNewEntry} -setup {
     .m1 insert 2 command -label "test2"
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e003}
 test menu-15.3 {MenuNewEntry} -setup {
     deleteWindows
 } -body {
@@ -2943,7 +2943,7 @@ test menu-15.3 {MenuNewEntry} -setup {
     .m1 add command -label "test2"
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e002}
 test menu-15.4 {MenuNewEntry} -setup {
     deleteWindows
 } -body {
@@ -2951,7 +2951,7 @@ test menu-15.4 {MenuNewEntry} -setup {
     .m1 add command -label "test"
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 
 test menu-16.1 {MenuAddOrInsert} -setup {
     deleteWindows
@@ -2967,7 +2967,7 @@ test menu-16.2 {MenuAddOrInsert} -setup {
     .m1 insert test command -label "foo"
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e002}
 test menu-16.3 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -2991,7 +2991,7 @@ test menu-16.5 {MenuAddOrInsert} -setup {
     .m1 add cascade
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-16.6 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -2999,7 +2999,7 @@ test menu-16.6 {MenuAddOrInsert} -setup {
     .m1 add checkbutton
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-16.7 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3007,7 +3007,7 @@ test menu-16.7 {MenuAddOrInsert} -setup {
     .m1 add command
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-16.8 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3015,7 +3015,7 @@ test menu-16.8 {MenuAddOrInsert} -setup {
     .m1 add radiobutton
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-16.9 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3023,7 +3023,7 @@ test menu-16.9 {MenuAddOrInsert} -setup {
     .m1 add separator
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-16.10 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3037,7 +3037,7 @@ test menu-16.11 {MenuAddOrInsert} -setup {
     .m1 add command
 } -cleanup {
     deleteWindows
-} -result {}
+} -result {e001}
 test menu-16.12 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3047,7 +3047,7 @@ test menu-16.12 {MenuAddOrInsert} -setup {
     list [.m2 add command -label "test"] [.m1 entrycget 1 -label] [.m3 entrycget 1 -label]
 } -cleanup {
     deleteWindows
-} -result {{} test test}
+} -result {e001 test test}
 test menu-16.13 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3057,12 +3057,12 @@ test menu-16.13 {MenuAddOrInsert} -setup {
     list [.m3 add command -label "test"] [.m1 entrycget 1 -label] [.m2 entrycget 1 -label]
 } -cleanup {
     deleteWindows
-} -result {{} test test}
+} -result {e001 test test}
 test menu-16.14 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
     menu .m1
-    .m1 add command -blork
+    .m1 add command -blork fish
 } -returnCodes error -result {unknown option "-blork"}
 test menu-16.15 {MenuAddOrInsert} -setup {
     deleteWindows
@@ -3074,7 +3074,7 @@ test menu-16.15 {MenuAddOrInsert} -setup {
     list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
 } -cleanup {
     deleteWindows
-} -result {{} {}}
+} -result {e001 {}}
 test menu-16.16 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3084,7 +3084,7 @@ test menu-16.16 {MenuAddOrInsert} -setup {
     list [.m2 add cascade -menu .m1] [$tearoff unpost]
 } -cleanup {
     deleteWindows
-} -result {{} {}}
+} -result {e001 {}}
 test menu-16.17 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3095,7 +3095,7 @@ test menu-16.17 {MenuAddOrInsert} -setup {
     list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
 } -cleanup {
     deleteWindows
-} -result {{} {}}
+} -result {e001 {}}
 test menu-16.18 {MenuAddOrInsert} -setup {
     deleteWindows
 } -body {
@@ -3106,7 +3106,7 @@ test menu-16.18 {MenuAddOrInsert} -setup {
     list [.container add cascade -label "File" -menu .m1] [. configure -menu ""]
 } -cleanup {
     deleteWindows
-} -result {{} {}}
+} -result {e002 {}}
 test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup {
     deleteWindows
 } -body {
@@ -3135,7 +3135,7 @@ test menu-17.1 {MenuVarProc} -setup {
             [unset foo]
 } -cleanup {
     deleteWindows
-} -result {{} {}}
+} -result {e001 {}}
 # menu-17.2 - Don't know how to generate the flags in the if
 test menu-17.2 {MenuVarProc} -setup {
     deleteWindows
@@ -3146,7 +3146,7 @@ test menu-17.2 {MenuVarProc} -setup {
             [set foo ""]
 } -cleanup {
     deleteWindows
-} -result {{} {}}
+} -result {e001 {}}
 test menu-17.3 {MenuVarProc} -setup {
     deleteWindows
 } -body {
@@ -3157,7 +3157,7 @@ test menu-17.3 {MenuVarProc} -setup {
             [set foo "hello"] [unset foo]
 } -cleanup {
     deleteWindows
-} -result {{} hello {}}
+} -result {e001 hello {}}
 test menu-17.4 {MenuVarProc} -setup {
     deleteWindows
 } -body {
@@ -3167,7 +3167,7 @@ test menu-17.4 {MenuVarProc} -setup {
             [set foo "hello"] [unset foo]
 } -cleanup {
     deleteWindows
-} -result {{} hello {}}
+} -result {e001 hello {}}
 test menu-17.5 {MenuVarProc} -setup {
     deleteWindows
 } -body {
@@ -3177,7 +3177,7 @@ test menu-17.5 {MenuVarProc} -setup {
             [set foo "goodbye"] [unset foo]
 } -cleanup {
     deleteWindows
-} -result {{} goodbye {}}
+} -result {e001 goodbye {}}
 test menu-17.6 {MenuVarProc [5d991b822e]} -setup {
     deleteWindows
 } -body {