diff options
Diffstat (limited to 'tk8.6/generic/tkMenu.c')
| -rw-r--r-- | tk8.6/generic/tkMenu.c | 3611 |
1 files changed, 0 insertions, 3611 deletions
diff --git a/tk8.6/generic/tkMenu.c b/tk8.6/generic/tkMenu.c deleted file mode 100644 index d24516f..0000000 --- a/tk8.6/generic/tkMenu.c +++ /dev/null @@ -1,3611 +0,0 @@ -/* - * tkMenu.c -- - * - * This file contains most of the code for implementing menus in Tk. It takes - * care of all of the generic (platform-independent) parts of menus, and is - * supplemented by platform-specific files. The geometry calculation and - * drawing code for menus is in the file tkMenuDraw.c - * - * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/* - * Notes on implementation of menus: - * - * Menus can be used in three ways: - * - as a popup menu, either as part of a menubutton or standalone. - * - as a menubar. The menu's cascade items are arranged according to the - * specific platform to provide the user access to the menus at all times - * - as a tearoff palette. This is a window with the menu's items in it. - * - * The goal is to provide the Tk developer with a way to use a common set of - * menus for all of these tasks. - * - * In order to make the bindings for cascade menus work properly under Unix, - * the cascade menus' pathnames must be proper children of the menu that they - * are cascade from. So if there is a menu .m, and it has two cascades - * labelled "File" and "Edit", the cascade menus might have the pathnames - * .m.file and .m.edit. Another constraint is that the menus used for menubars - * must be children of the toplevel widget that they are attached to. And on - * the Macintosh, the platform specific menu handle for cascades attached to a - * menu bar must have a title that matches the label for the cascade menu. - * - * To handle all of the constraints, Tk menubars and tearoff menus are - * implemented using menu clones. Menu clones are full menus in their own - * right; they have a Tk window and pathname associated with them; they have a - * TkMenu structure and array of entries. However, they are linked with the - * original menu that they were cloned from. The reflect the attributes of the - * original, or "master", menu. So if an item is added to a menu, and that - * menu has clones, then the item must be added to all of its clones also. - * Menus are cloned when a menu is torn-off or when a menu is assigned as a - * menubar using the "-menu" option of the toplevel's pathname configure - * subcommand. When a clone is destroyed, only the clone is destroyed, but - * when the master menu is destroyed, all clones are also destroyed. This - * allows the developer to just deal with one set of menus when creating and - * destroying. - * - * Clones are rather tricky when a menu with cascade entries is cloned (such - * as a menubar). Not only does the menu have to be cloned, but each cascade - * entry's corresponding menu must also be cloned. This maintains the pathname - * parent-child hierarchy necessary for menubars and toplevels to work. This - * leads to several special cases: - * - * 1. When a new menu is created, and it is pointed to by cascade entries in - * cloned menus, the new menu has to be cloned to parallel the cascade - * structure. - * 2. When a cascade item is added to a menu that has been cloned, and the - * menu that the cascade item points to exists, that menu has to be cloned. - * 3. When the menu that a cascade entry points to is changed, the old cloned - * cascade menu has to be discarded, and the new one has to be cloned. - */ - -#if 0 - -/* - * used only to test for old config code - */ - -#define __NO_OLD_CONFIG -#endif - -#include "tkInt.h" -#include "tkMenu.h" - -#define MENU_HASH_KEY "tkMenus" - -typedef struct ThreadSpecificData { - int menusInitialized; /* Flag indicates whether thread-specific - * elements of the Windows Menu module have - * been initialized. */ - Tk_OptionTable menuOptionTable; - /* The option table for menus. */ - Tk_OptionTable entryOptionTables[6]; - /* The tables for menu entries. */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; - -/* - * The following flag indicates whether the process-wide state for the Menu - * module has been intialized. The Mutex protects access to that flag. - */ - -static int menusInitialized; -TCL_DECLARE_MUTEX(menuMutex) - -/* - * Configuration specs for individual menu entries. If this changes, be sure - * to update code in TkpMenuInit that changes the font string entry. - */ - -static const char *const menuStateStrings[] = {"active", "normal", "disabled", NULL}; - -static const char *const menuEntryTypeStrings[] = { - "cascade", "checkbutton", "command", "radiobutton", "separator", NULL -}; - -/* - * The following table defines the legal values for the -compound option. It - * is used with the "enum compound" declaration in tkMenu.h - */ - -static const char *const compoundStrings[] = { - "bottom", "center", "left", "none", "right", "top", NULL -}; - -static const Tk_OptionSpec tkBasicMenuEntryConfigSpecs[] = { - {TK_OPTION_BORDER, "-activebackground", NULL, NULL, - DEF_MENU_ENTRY_ACTIVE_BG, Tk_Offset(TkMenuEntry, activeBorderPtr), -1, - TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_COLOR, "-activeforeground", NULL, NULL, - DEF_MENU_ENTRY_ACTIVE_FG, - Tk_Offset(TkMenuEntry, activeFgPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-accelerator", NULL, NULL, - DEF_MENU_ENTRY_ACCELERATOR, - Tk_Offset(TkMenuEntry, accelPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_BORDER, "-background", NULL, NULL, - DEF_MENU_ENTRY_BG, - Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_BITMAP, "-bitmap", NULL, NULL, - DEF_MENU_ENTRY_BITMAP, - Tk_Offset(TkMenuEntry, bitmapPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_BOOLEAN, "-columnbreak", NULL, NULL, - DEF_MENU_ENTRY_COLUMN_BREAK, - -1, Tk_Offset(TkMenuEntry, columnBreak), 0, NULL, 0}, - {TK_OPTION_STRING, "-command", NULL, NULL, - DEF_MENU_ENTRY_COMMAND, - Tk_Offset(TkMenuEntry, commandPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING_TABLE, "-compound", "compound", "Compound", - DEF_MENU_ENTRY_COMPOUND, -1, Tk_Offset(TkMenuEntry, compound), 0, - (ClientData) compoundStrings, 0}, - {TK_OPTION_FONT, "-font", NULL, NULL, - DEF_MENU_ENTRY_FONT, - Tk_Offset(TkMenuEntry, fontPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_COLOR, "-foreground", NULL, NULL, - DEF_MENU_ENTRY_FG, - Tk_Offset(TkMenuEntry, fgPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_BOOLEAN, "-hidemargin", NULL, NULL, - DEF_MENU_ENTRY_HIDE_MARGIN, - -1, Tk_Offset(TkMenuEntry, hideMargin), 0, NULL, 0}, - {TK_OPTION_STRING, "-image", NULL, NULL, - DEF_MENU_ENTRY_IMAGE, - Tk_Offset(TkMenuEntry, imagePtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-label", NULL, NULL, - DEF_MENU_ENTRY_LABEL, - Tk_Offset(TkMenuEntry, labelPtr), -1, 0, NULL, 0}, - {TK_OPTION_STRING_TABLE, "-state", NULL, NULL, - DEF_MENU_ENTRY_STATE, - -1, Tk_Offset(TkMenuEntry, state), 0, - (ClientData) menuStateStrings, 0}, - {TK_OPTION_INT, "-underline", NULL, NULL, - DEF_MENU_ENTRY_UNDERLINE, -1, Tk_Offset(TkMenuEntry, underline), 0, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, 0, 0, 0, 0, NULL, 0} -}; - -static const Tk_OptionSpec tkSeparatorEntryConfigSpecs[] = { - {TK_OPTION_BORDER, "-background", NULL, NULL, - DEF_MENU_ENTRY_BG, - Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, 0, 0, 0, 0, NULL, 0} -}; - -static const Tk_OptionSpec tkCheckButtonEntryConfigSpecs[] = { - {TK_OPTION_BOOLEAN, "-indicatoron", NULL, NULL, - DEF_MENU_ENTRY_INDICATOR, - -1, Tk_Offset(TkMenuEntry, indicatorOn), 0, NULL, 0}, - {TK_OPTION_STRING, "-offvalue", NULL, NULL, - DEF_MENU_ENTRY_OFF_VALUE, - Tk_Offset(TkMenuEntry, offValuePtr), -1, 0, NULL, 0}, - {TK_OPTION_STRING, "-onvalue", NULL, NULL, - DEF_MENU_ENTRY_ON_VALUE, - Tk_Offset(TkMenuEntry, onValuePtr), -1, 0, NULL, 0}, - {TK_OPTION_COLOR, "-selectcolor", NULL, NULL, - DEF_MENU_ENTRY_SELECT, - Tk_Offset(TkMenuEntry, indicatorFgPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-selectimage", NULL, NULL, - DEF_MENU_ENTRY_SELECT_IMAGE, - Tk_Offset(TkMenuEntry, selectImagePtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-variable", NULL, NULL, - DEF_MENU_ENTRY_CHECK_VARIABLE, - Tk_Offset(TkMenuEntry, namePtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, - NULL, 0, -1, 0, tkBasicMenuEntryConfigSpecs, 0} -}; - -static const Tk_OptionSpec tkRadioButtonEntryConfigSpecs[] = { - {TK_OPTION_BOOLEAN, "-indicatoron", NULL, NULL, - DEF_MENU_ENTRY_INDICATOR, - -1, Tk_Offset(TkMenuEntry, indicatorOn), 0, NULL, 0}, - {TK_OPTION_COLOR, "-selectcolor", NULL, NULL, - DEF_MENU_ENTRY_SELECT, - Tk_Offset(TkMenuEntry, indicatorFgPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-selectimage", NULL, NULL, - DEF_MENU_ENTRY_SELECT_IMAGE, - Tk_Offset(TkMenuEntry, selectImagePtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-value", NULL, NULL, - DEF_MENU_ENTRY_VALUE, - Tk_Offset(TkMenuEntry, onValuePtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-variable", NULL, NULL, - DEF_MENU_ENTRY_RADIO_VARIABLE, - Tk_Offset(TkMenuEntry, namePtr), -1, 0, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, - NULL, 0, -1, 0, tkBasicMenuEntryConfigSpecs, 0} -}; - -static const Tk_OptionSpec tkCascadeEntryConfigSpecs[] = { - {TK_OPTION_STRING, "-menu", NULL, NULL, - DEF_MENU_ENTRY_MENU, - Tk_Offset(TkMenuEntry, namePtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, - NULL, 0, -1, 0, tkBasicMenuEntryConfigSpecs, 0} -}; - -static const Tk_OptionSpec tkTearoffEntryConfigSpecs[] = { - {TK_OPTION_BORDER, "-background", NULL, NULL, - DEF_MENU_ENTRY_BG, - Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING_TABLE, "-state", NULL, NULL, - DEF_MENU_ENTRY_STATE, -1, Tk_Offset(TkMenuEntry, state), 0, - (ClientData) menuStateStrings, 0}, - {TK_OPTION_END, NULL, NULL, NULL, 0, 0, 0, 0, NULL, 0} -}; - -static const Tk_OptionSpec *specsArray[] = { - tkCascadeEntryConfigSpecs, tkCheckButtonEntryConfigSpecs, - tkBasicMenuEntryConfigSpecs, tkRadioButtonEntryConfigSpecs, - tkSeparatorEntryConfigSpecs, tkTearoffEntryConfigSpecs -}; - -/* - * Menu type strings for use with Tcl_GetIndexFromObj. - */ - -static const char *const menuTypeStrings[] = { - "normal", "tearoff", "menubar", NULL -}; - -static const Tk_OptionSpec tkMenuConfigSpecs[] = { - {TK_OPTION_BORDER, "-activebackground", "activeBackground", - "Foreground", DEF_MENU_ACTIVE_BG_COLOR, - Tk_Offset(TkMenu, activeBorderPtr), -1, 0, - (ClientData) DEF_MENU_ACTIVE_BG_MONO, 0}, - {TK_OPTION_PIXELS, "-activeborderwidth", "activeBorderWidth", - "BorderWidth", DEF_MENU_ACTIVE_BORDER_WIDTH, - Tk_Offset(TkMenu, activeBorderWidthPtr), -1, 0, NULL, 0}, - {TK_OPTION_COLOR, "-activeforeground", "activeForeground", - "Background", DEF_MENU_ACTIVE_FG_COLOR, - Tk_Offset(TkMenu, activeFgPtr), -1, 0, - (ClientData) DEF_MENU_ACTIVE_FG_MONO, 0}, - {TK_OPTION_BORDER, "-background", "background", "Background", - DEF_MENU_BG_COLOR, Tk_Offset(TkMenu, borderPtr), -1, 0, - (ClientData) DEF_MENU_BG_MONO, 0}, - {TK_OPTION_SYNONYM, "-bd", NULL, NULL, - NULL, 0, -1, 0, "-borderwidth", 0}, - {TK_OPTION_SYNONYM, "-bg", NULL, NULL, - NULL, 0, -1, 0, "-background", 0}, - {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_MENU_BORDER_WIDTH, - Tk_Offset(TkMenu, borderWidthPtr), -1, 0, NULL, 0}, - {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", - DEF_MENU_CURSOR, - Tk_Offset(TkMenu, cursorPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_COLOR, "-disabledforeground", "disabledForeground", - "DisabledForeground", DEF_MENU_DISABLED_FG_COLOR, - Tk_Offset(TkMenu, disabledFgPtr), -1, TK_OPTION_NULL_OK, - (ClientData) DEF_MENU_DISABLED_FG_MONO, 0}, - {TK_OPTION_SYNONYM, "-fg", NULL, NULL, - NULL, 0, -1, 0, "-foreground", 0}, - {TK_OPTION_FONT, "-font", "font", "Font", - DEF_MENU_FONT, Tk_Offset(TkMenu, fontPtr), -1, 0, NULL, 0}, - {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", - DEF_MENU_FG, Tk_Offset(TkMenu, fgPtr), -1, 0, NULL, 0}, - {TK_OPTION_STRING, "-postcommand", "postCommand", "Command", - DEF_MENU_POST_COMMAND, - Tk_Offset(TkMenu, postCommandPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_RELIEF, "-relief", "relief", "Relief", - DEF_MENU_RELIEF, Tk_Offset(TkMenu, reliefPtr), -1, 0, NULL, 0}, - {TK_OPTION_COLOR, "-selectcolor", "selectColor", "Background", - DEF_MENU_SELECT_COLOR, Tk_Offset(TkMenu, indicatorFgPtr), -1, 0, - (ClientData) DEF_MENU_SELECT_MONO, 0}, - {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", - DEF_MENU_TAKE_FOCUS, - Tk_Offset(TkMenu, takeFocusPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_BOOLEAN, "-tearoff", "tearOff", "TearOff", - DEF_MENU_TEAROFF, -1, Tk_Offset(TkMenu, tearoff), 0, NULL, 0}, - {TK_OPTION_STRING, "-tearoffcommand", "tearOffCommand", - "TearOffCommand", DEF_MENU_TEAROFF_CMD, - Tk_Offset(TkMenu, tearoffCommandPtr), -1, TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING, "-title", "title", "Title", - DEF_MENU_TITLE, Tk_Offset(TkMenu, titlePtr), -1, - TK_OPTION_NULL_OK, NULL, 0}, - {TK_OPTION_STRING_TABLE, "-type", "type", "Type", - DEF_MENU_TYPE, Tk_Offset(TkMenu, menuTypePtr), -1, TK_OPTION_NULL_OK, - (ClientData) menuTypeStrings, 0}, - {TK_OPTION_END, NULL, NULL, NULL, 0, 0, 0, 0, NULL, 0} -}; - -/* - * Command line options. Put here because MenuCmd has to look at them along - * with MenuWidgetObjCmd. - */ - -static const char *const menuOptions[] = { - "activate", "add", "cget", "clone", "configure", "delete", "entrycget", - "entryconfigure", "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_INSERT, MENU_INVOKE, MENU_POST, MENU_POSTCASCADE, MENU_TYPE, - MENU_UNPOST, MENU_XPOSITION, MENU_YPOSITION -}; - -/* - * Prototypes for static functions in this file: - */ - -static int CloneMenu(TkMenu *menuPtr, Tcl_Obj *newMenuName, - Tcl_Obj *newMenuTypeString); -static int ConfigureMenu(Tcl_Interp *interp, TkMenu *menuPtr, - int objc, Tcl_Obj *const objv[]); -static int ConfigureMenuCloneEntries(Tcl_Interp *interp, - TkMenu *menuPtr, int index, - int objc, Tcl_Obj *const objv[]); -static int ConfigureMenuEntry(TkMenuEntry *mePtr, - int objc, Tcl_Obj *const objv[]); -static void DeleteMenuCloneEntries(TkMenu *menuPtr, - int first, int last); -static void DestroyMenuHashTable(ClientData clientData, - Tcl_Interp *interp); -static void DestroyMenuInstance(TkMenu *menuPtr); -static void DestroyMenuEntry(void *memPtr); -static int GetIndexFromCoords(Tcl_Interp *interp, - TkMenu *menuPtr, const 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[]); -static void MenuCmdDeletedProc(ClientData clientData); -static TkMenuEntry * MenuNewEntry(TkMenu *menuPtr, int index, int type); -static char * MenuVarProc(ClientData clientData, - Tcl_Interp *interp, const char *name1, - const char *name2, int flags); -static int MenuWidgetObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static void MenuWorldChanged(ClientData instanceData); -static int PostProcessEntry(TkMenuEntry *mePtr); -static void RecursivelyDeleteMenu(TkMenu *menuPtr); -static void UnhookCascadeEntry(TkMenuEntry *mePtr); -static void TkMenuCleanup(ClientData unused); - -/* - * The structure below is a list of procs that respond to certain window - * manager events. One of these includes a font change, which forces the - * geometry proc to be called. - */ - -static const Tk_ClassProcs menuClass = { - sizeof(Tk_ClassProcs), /* size */ - MenuWorldChanged, /* worldChangedProc */ - NULL, /* createProc */ - NULL /* modalProc */ -}; - -/* - *-------------------------------------------------------------- - * - * Tk_MenuObjCmd -- - * - * This function is invoked to process the "menu" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_MenuObjCmd( - ClientData clientData, /* Main window associated with interpreter. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - Tk_Window tkwin = clientData; - Tk_Window newWin; - register TkMenu *menuPtr; - TkMenuReferences *menuRefPtr; - int i, index, toplevel; - const char *windowName; - static const char *const typeStringList[] = {"-type", NULL}; - ThreadSpecificData *tsdPtr = - Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "pathName ?-option value ...?"); - return TCL_ERROR; - } - - TkMenuInit(); - - toplevel = 1; - for (i = 2; i < (objc - 1); i++) { - if (Tcl_GetIndexFromObjStruct(NULL, objv[i], typeStringList, - sizeof(char *), NULL, 0, &index) != TCL_ERROR) { - if ((Tcl_GetIndexFromObjStruct(NULL, objv[i + 1], menuTypeStrings, - sizeof(char *), NULL, 0, &index) == TCL_OK) && (index == MENUBAR)) { - toplevel = 0; - } - break; - } - } - - windowName = Tcl_GetString(objv[1]); - newWin = Tk_CreateWindowFromPath(interp, tkwin, windowName, - toplevel ? "" : NULL); - if (newWin == NULL) { - return TCL_ERROR; - } - - /* - * Initialize the data structure for the menu. Note that the menuPtr is - * eventually freed in 'TkMenuEventProc' in tkMenuDraw.c, when - * Tcl_EventuallyFree is called. - */ - - menuPtr = ckalloc(sizeof(TkMenu)); - memset(menuPtr, 0, sizeof(TkMenu)); - menuPtr->tkwin = newWin; - menuPtr->display = Tk_Display(newWin); - menuPtr->interp = interp; - menuPtr->widgetCmd = Tcl_CreateObjCommand(interp, - Tk_PathName(menuPtr->tkwin), MenuWidgetObjCmd, menuPtr, - MenuCmdDeletedProc); - menuPtr->active = -1; - menuPtr->cursorPtr = None; - menuPtr->masterMenuPtr = menuPtr; - menuPtr->menuType = UNKNOWN_TYPE; - TkMenuInitializeDrawingFields(menuPtr); - - Tk_SetClass(menuPtr->tkwin, "Menu"); - Tk_SetClassProcs(menuPtr->tkwin, &menuClass, menuPtr); - Tk_CreateEventHandler(newWin, - ExposureMask|StructureNotifyMask|ActivateMask, - TkMenuEventProc, menuPtr); - if (Tk_InitOptions(interp, (char *) menuPtr, - tsdPtr->menuOptionTable, menuPtr->tkwin) - != TCL_OK) { - Tk_DestroyWindow(menuPtr->tkwin); - return TCL_ERROR; - } - - - menuRefPtr = TkCreateMenuReferences(menuPtr->interp, - Tk_PathName(menuPtr->tkwin)); - menuRefPtr->menuPtr = menuPtr; - menuPtr->menuRefPtr = menuRefPtr; - if (TCL_OK != TkpNewMenu(menuPtr)) { - Tk_DestroyWindow(menuPtr->tkwin); - return TCL_ERROR; - } - - if (ConfigureMenu(interp, menuPtr, objc - 2, objv + 2) != TCL_OK) { - Tk_DestroyWindow(menuPtr->tkwin); - return TCL_ERROR; - } - - /* - * If a menu has a parent menu pointing to it as a cascade entry, the - * parent menu needs to be told that this menu now exists so that the - * platform-part of the menu is correctly updated. - * - * If a menu has an instance and has cascade entries, then each cascade - * menu must also have a parallel instance. This is especially true on the - * Mac, where each menu has to have a separate title everytime it is in a - * menubar. For instance, say you have a menu .m1 with a cascade entry for - * .m2, where .m2 does not exist yet. You then put .m1 into a menubar. - * This creates a menubar instance for .m1, but since .m2 is not there, - * nothing else happens. When we go to create .m2, we hook it up properly - * with .m1. However, we now need to clone .m2 and assign the clone of .m2 - * to be the cascade entry for the clone of .m1. This is special case #1 - * listed in the introductory comment. - */ - - if (menuRefPtr->parentEntryPtr != NULL) { - TkMenuEntry *cascadeListPtr = menuRefPtr->parentEntryPtr; - TkMenuEntry *nextCascadePtr; - Tcl_Obj *newMenuName, *newObjv[2]; - - while (cascadeListPtr != NULL) { - nextCascadePtr = cascadeListPtr->nextCascadePtr; - - /* - * If we have a new master menu, and an existing cloned menu - * points to this menu in a cascade entry, we have to clone the - * new menu and point the entry to the clone instead of the menu - * we are creating. Otherwise, ConfigureMenuEntry will hook up the - * platform-specific cascade linkages now that the menu we are - * creating exists. - */ - - if ((menuPtr->masterMenuPtr != menuPtr) - || ((menuPtr->masterMenuPtr == menuPtr) - && ((cascadeListPtr->menuPtr->masterMenuPtr - == cascadeListPtr->menuPtr)))) { - newObjv[0] = Tcl_NewStringObj("-menu", -1); - newObjv[1] = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin),-1); - Tcl_IncrRefCount(newObjv[0]); - Tcl_IncrRefCount(newObjv[1]); - ConfigureMenuEntry(cascadeListPtr, 2, newObjv); - Tcl_DecrRefCount(newObjv[0]); - Tcl_DecrRefCount(newObjv[1]); - } else { - Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1); - Tcl_Obj *windowNamePtr = Tcl_NewStringObj( - Tk_PathName(cascadeListPtr->menuPtr->tkwin), -1); - - Tcl_IncrRefCount(normalPtr); - Tcl_IncrRefCount(windowNamePtr); - newMenuName = TkNewMenuName(menuPtr->interp, - windowNamePtr, menuPtr); - Tcl_IncrRefCount(newMenuName); - CloneMenu(menuPtr, newMenuName, normalPtr); - - /* - * Now we can set the new menu instance to be the cascade - * entry of the parent's instance. - */ - - newObjv[0] = Tcl_NewStringObj("-menu", -1); - newObjv[1] = newMenuName; - Tcl_IncrRefCount(newObjv[0]); - ConfigureMenuEntry(cascadeListPtr, 2, newObjv); - Tcl_DecrRefCount(normalPtr); - Tcl_DecrRefCount(newObjv[0]); - Tcl_DecrRefCount(newObjv[1]); - Tcl_DecrRefCount(windowNamePtr); - } - cascadeListPtr = nextCascadePtr; - } - } - - /* - * If there already exist toplevel widgets that refer to this menu, find - * them and notify them so that they can reconfigure their geometry to - * reflect the menu. - */ - - if (menuRefPtr->topLevelListPtr != NULL) { - TkMenuTopLevelList *topLevelListPtr = menuRefPtr->topLevelListPtr; - TkMenuTopLevelList *nextPtr; - Tk_Window listtkwin; - - while (topLevelListPtr != NULL) { - /* - * Need to get the next pointer first. TkSetWindowMenuBar changes - * the list, so that the next pointer is different after calling - * it. - */ - - nextPtr = topLevelListPtr->nextPtr; - listtkwin = topLevelListPtr->tkwin; - TkSetWindowMenuBar(menuPtr->interp, listtkwin, - Tk_PathName(menuPtr->tkwin), Tk_PathName(menuPtr->tkwin)); - topLevelListPtr = nextPtr; - } - } - - Tcl_SetObjResult(interp, TkNewWindowObj(menuPtr->tkwin)); - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * MenuWidgetObjCmd -- - * - * This function is invoked to process the Tcl command that corresponds - * to a widget managed by this module. See the user documentation for - * details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -static int -MenuWidgetObjCmd( - ClientData clientData, /* Information about menu widget. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - register TkMenu *menuPtr = clientData; - register TkMenuEntry *mePtr; - int result = TCL_OK; - int option; - ThreadSpecificData *tsdPtr = - Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObjStruct(interp, objv[1], menuOptions, - sizeof(char *), "option", 0, &option) != TCL_OK) { - return TCL_ERROR; - } - Tcl_Preserve(menuPtr); - - switch ((enum options) option) { - case MENU_ACTIVATE: { - int index; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) { - goto error; - } - if (menuPtr->active == index) { - goto done; - } - if ((index >= 0) && ((menuPtr->entries[index]->type==SEPARATOR_ENTRY) - || (menuPtr->entries[index]->state == ENTRY_DISABLED))) { - index = -1; - } - result = TkActivateMenuEntry(menuPtr, index); - break; - } - case MENU_ADD: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "type ?-option value ...?"); - goto error; - } - - if (MenuAddOrInsert(interp, menuPtr, NULL, objc-2, objv+2) != TCL_OK){ - goto error; - } - break; - case MENU_CGET: { - Tcl_Obj *resultPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "option"); - goto error; - } - resultPtr = Tk_GetOptionValue(interp, (char *) menuPtr, - tsdPtr->menuOptionTable, objv[2], - menuPtr->tkwin); - if (resultPtr == NULL) { - goto error; - } - Tcl_SetObjResult(interp, resultPtr); - break; - } - case MENU_CLONE: - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "newMenuName ?menuType?"); - goto error; - } - result = CloneMenu(menuPtr, objv[2], (objc == 3) ? NULL : objv[3]); - break; - case MENU_CONFIGURE: { - Tcl_Obj *resultPtr; - - if (objc == 2) { - resultPtr = Tk_GetOptionInfo(interp, (char *) menuPtr, - tsdPtr->menuOptionTable, NULL, - menuPtr->tkwin); - if (resultPtr == NULL) { - result = TCL_ERROR; - } else { - result = TCL_OK; - Tcl_SetObjResult(interp, resultPtr); - } - } else if (objc == 3) { - resultPtr = Tk_GetOptionInfo(interp, (char *) menuPtr, - tsdPtr->menuOptionTable, objv[2], - menuPtr->tkwin); - if (resultPtr == NULL) { - result = TCL_ERROR; - } else { - result = TCL_OK; - Tcl_SetObjResult(interp, resultPtr); - } - } else { - result = ConfigureMenu(interp, menuPtr, objc - 2, objv + 2); - } - if (result != TCL_OK) { - goto error; - } - break; - } - case MENU_DELETE: { - int first, last; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "first ?last?"); - goto error; - } - - /* - * If 'first' explicitly refers to past the end of the menu, we don't - * do anything. [Bug 220950] - */ - - if (isdigit(UCHAR(Tcl_GetString(objv[2])[0])) - && Tcl_GetIntFromObj(NULL, objv[2], &first) == TCL_OK) { - if (first >= menuPtr->numEntries) { - goto done; - } - } else if (TkGetMenuIndex(interp,menuPtr,objv[2],0,&first) != TCL_OK){ - goto error; - } - if (objc == 3) { - last = first; - } else if (TkGetMenuIndex(interp,menuPtr,objv[3],0,&last) != TCL_OK) { - goto error; - } - - if (menuPtr->tearoff && (first == 0)) { - /* - * Sorry, can't delete the tearoff entry; must reconfigure the - * menu. - */ - - first = 1; - } - if ((first < 0) || (last < first)) { - goto done; - } - DeleteMenuCloneEntries(menuPtr, first, last); - break; - } - case MENU_ENTRYCGET: { - int index; - Tcl_Obj *resultPtr; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "index option"); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - mePtr = menuPtr->entries[index]; - Tcl_Preserve(mePtr); - resultPtr = Tk_GetOptionValue(interp, (char *) mePtr, - mePtr->optionTable, objv[3], menuPtr->tkwin); - Tcl_Release(mePtr); - if (resultPtr == NULL) { - goto error; - } - Tcl_SetObjResult(interp, resultPtr); - break; - } - case MENU_ENTRYCONFIGURE: { - int index; - Tcl_Obj *resultPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index ?-option value ...?"); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - mePtr = menuPtr->entries[index]; - Tcl_Preserve(mePtr); - if (objc == 3) { - resultPtr = Tk_GetOptionInfo(interp, (char *) mePtr, - mePtr->optionTable, NULL, menuPtr->tkwin); - if (resultPtr == NULL) { - result = TCL_ERROR; - } else { - result = TCL_OK; - Tcl_SetObjResult(interp, resultPtr); - } - } else if (objc == 4) { - resultPtr = Tk_GetOptionInfo(interp, (char *) mePtr, - mePtr->optionTable, objv[3], menuPtr->tkwin); - if (resultPtr == NULL) { - result = TCL_ERROR; - } else { - result = TCL_OK; - Tcl_SetObjResult(interp, resultPtr); - } - } else { - result = ConfigureMenuCloneEntries(interp, menuPtr, index, - objc-3, objv+3); - } - Tcl_Release(mePtr); - break; - } - case MENU_INDEX: { - int index; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); - } - break; - } - case MENU_INSERT: - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "index type ?-option value ...?"); - goto error; - } - if (MenuAddOrInsert(interp,menuPtr,objv[2],objc-3,objv+3) != TCL_OK) { - goto error; - } - break; - case MENU_INVOKE: { - int index; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - result = TkInvokeMenu(interp, menuPtr, index); - break; - } - case MENU_POST: { - int x, y; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "x y"); - goto error; - } - if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) { - goto error; - } - - /* - * Tearoff menus are posted differently on Mac and Windows than - * non-tearoffs. TkpPostMenu does not actually map the menu's window - * on those platforms, and popup menus have to be handled specially. - * Also, menubar menues are not intended to be posted (bug 1567681, - * 2160206). - */ - - if (menuPtr->menuType == MENUBAR) { - Tcl_AppendResult(interp, "a menubar menu cannot be posted", NULL); - return TCL_ERROR; - } else if (menuPtr->menuType != TEAROFF_MENU) { - result = TkpPostMenu(interp, menuPtr, x, y); - } else { - result = TkPostTearoffMenu(interp, menuPtr, x, y); - } - break; - } - case MENU_POSTCASCADE: { - int index; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - goto error; - } - - if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) { - goto error; - } - if ((index < 0) || (menuPtr->entries[index]->type != CASCADE_ENTRY)) { - result = TkPostSubmenu(interp, menuPtr, NULL); - } else { - result = TkPostSubmenu(interp, menuPtr, menuPtr->entries[index]); - } - break; - } - case MENU_TYPE: { - int index; - const char *typeStr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - if (menuPtr->entries[index]->type == TEAROFF_ENTRY) { - typeStr = "tearoff"; - } else { - typeStr = menuEntryTypeStrings[menuPtr->entries[index]->type]; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(typeStr, -1)); - break; - } - case MENU_UNPOST: - if (objc != 2) { - 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, 2, objv, "index"); - goto error; - } - result = MenuDoYPosition(interp, menuPtr, objv[2]); - break; - } - done: - Tcl_Release(menuPtr); - return result; - - error: - Tcl_Release(menuPtr); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TkInvokeMenu -- - * - * Given a menu and an index, takes the appropriate action for the entry - * associated with that index. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Commands may get excecuted; variables may get set; sub-menus may get - * posted. - * - *---------------------------------------------------------------------- - */ - -int -TkInvokeMenu( - Tcl_Interp *interp, /* The interp that the menu lives in. */ - TkMenu *menuPtr, /* The menu we are invoking. */ - int index) /* The zero based index of the item we are - * invoking. */ -{ - int result = TCL_OK; - TkMenuEntry *mePtr; - - if (index < 0) { - goto done; - } - mePtr = menuPtr->entries[index]; - if (mePtr->state == ENTRY_DISABLED) { - goto done; - } - - Tcl_Preserve(mePtr); - if (mePtr->type == TEAROFF_ENTRY) { - Tcl_DString ds; - - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, "tk::TearOffMenu ", -1); - Tcl_DStringAppend(&ds, Tk_PathName(menuPtr->tkwin), -1); - result = Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); - Tcl_DStringFree(&ds); - } else if ((mePtr->type == CHECK_BUTTON_ENTRY) - && (mePtr->namePtr != NULL)) { - Tcl_Obj *valuePtr; - - if (mePtr->entryFlags & ENTRY_SELECTED) { - valuePtr = mePtr->offValuePtr; - } else { - valuePtr = mePtr->onValuePtr; - } - if (valuePtr == NULL) { - valuePtr = Tcl_NewObj(); - } - Tcl_IncrRefCount(valuePtr); - if (Tcl_ObjSetVar2(interp, mePtr->namePtr, NULL, valuePtr, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - } - Tcl_DecrRefCount(valuePtr); - } else if ((mePtr->type == RADIO_BUTTON_ENTRY) - && (mePtr->namePtr != NULL)) { - Tcl_Obj *valuePtr = mePtr->onValuePtr; - - if (valuePtr == NULL) { - valuePtr = Tcl_NewObj(); - } - Tcl_IncrRefCount(valuePtr); - if (Tcl_ObjSetVar2(interp, mePtr->namePtr, NULL, valuePtr, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - } - Tcl_DecrRefCount(valuePtr); - } - - /* - * We check numEntries in addition to whether the menu entry has a command - * because that goes to zero if the menu gets deleted (e.g., during - * command evaluation). - */ - - if ((menuPtr->numEntries != 0) && (result == TCL_OK) - && (mePtr->commandPtr != NULL)) { - Tcl_Obj *commandPtr = mePtr->commandPtr; - - Tcl_IncrRefCount(commandPtr); - result = Tcl_EvalObjEx(interp, commandPtr, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(commandPtr); - } - Tcl_Release(mePtr); - - done: - return result; -} - -/* - *---------------------------------------------------------------------- - * - * DestroyMenuInstance -- - * - * This function is invoked by TkDestroyMenu to clean up the internal - * structure of a menu at a safe time (when no-one is using it anymore). - * Only takes care of one instance of the menu. - * - * Results: - * None. - * - * Side effects: - * Everything associated with the menu is freed up. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyMenuInstance( - TkMenu *menuPtr) /* Info about menu widget. */ -{ - int i; - TkMenu *menuInstancePtr; - TkMenuEntry *cascadePtr, *nextCascadePtr; - Tcl_Obj *newObjv[2]; - TkMenu *parentMasterMenuPtr; - TkMenuEntry *parentMasterEntryPtr; - ThreadSpecificData *tsdPtr = - Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); - - /* - * If the menu has any cascade menu entries pointing to it, the cascade - * entries need to be told that the menu is going away. We need to clear - * the menu ptr field in the menu reference at this point in the code so - * that everything else can forget about this menu properly. We also need - * to reset -menu field of all entries that are not master menus back to - * this entry name if this is a master menu pointed to by another master - * menu. If there is a clone menu that points to this menu, then this menu - * is itself a clone, so when this menu goes away, the -menu field of the - * pointing entry must be set back to this menu's master menu name so that - * later if another menu is created the cascade hierarchy can be - * maintained. - */ - - TkpDestroyMenu(menuPtr); - if (menuPtr->menuRefPtr == NULL) { - return; - } - cascadePtr = menuPtr->menuRefPtr->parentEntryPtr; - menuPtr->menuRefPtr->menuPtr = NULL; - if (TkFreeMenuReferences(menuPtr->menuRefPtr)) { - menuPtr->menuRefPtr = NULL; - } - - for (; cascadePtr != NULL; cascadePtr = nextCascadePtr) { - nextCascadePtr = cascadePtr->nextCascadePtr; - - if (menuPtr->masterMenuPtr != menuPtr) { - Tcl_Obj *menuNamePtr = Tcl_NewStringObj("-menu", -1); - - parentMasterMenuPtr = cascadePtr->menuPtr->masterMenuPtr; - parentMasterEntryPtr = - parentMasterMenuPtr->entries[cascadePtr->index]; - newObjv[0] = menuNamePtr; - newObjv[1] = parentMasterEntryPtr->namePtr; - - /* - * It is possible that the menu info is out of sync, and these - * things point to NULL, so verify existence [Bug: 3402] - */ - - if (newObjv[0] && newObjv[1]) { - Tcl_IncrRefCount(newObjv[0]); - Tcl_IncrRefCount(newObjv[1]); - ConfigureMenuEntry(cascadePtr, 2, newObjv); - Tcl_DecrRefCount(newObjv[0]); - Tcl_DecrRefCount(newObjv[1]); - } - } else { - ConfigureMenuEntry(cascadePtr, 0, NULL); - } - } - - if (menuPtr->masterMenuPtr != menuPtr) { - for (menuInstancePtr = menuPtr->masterMenuPtr; - menuInstancePtr != NULL; - menuInstancePtr = menuInstancePtr->nextInstancePtr) { - if (menuInstancePtr->nextInstancePtr == menuPtr) { - menuInstancePtr->nextInstancePtr = - menuInstancePtr->nextInstancePtr->nextInstancePtr; - break; - } - } - } else if (menuPtr->nextInstancePtr != NULL) { - Tcl_Panic("Attempting to delete master menu when there are still clones"); - } - - /* - * Free up all the stuff that requires special handling, then let - * Tk_FreeConfigOptions handle all the standard option-related stuff. - */ - - for (i = menuPtr->numEntries; --i >= 0; ) { - /* - * As each menu entry is deleted from the end of the array of entries, - * decrement menuPtr->numEntries. Otherwise, the act of deleting menu - * entry i will dereference freed memory attempting to queue a redraw - * for menu entries (i+1)...numEntries. - */ - - DestroyMenuEntry(menuPtr->entries[i]); - menuPtr->numEntries = i; - } - if (menuPtr->entries != NULL) { - ckfree(menuPtr->entries); - } - TkMenuFreeDrawOptions(menuPtr); - Tk_FreeConfigOptions((char *) menuPtr, - tsdPtr->menuOptionTable, menuPtr->tkwin); - if (menuPtr->tkwin != NULL) { - Tk_Window tkwin = menuPtr->tkwin; - - menuPtr->tkwin = NULL; - Tk_DestroyWindow(tkwin); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkDestroyMenu -- - * - * This function is invoked by Tcl_EventuallyFree or Tcl_Release to clean - * up the internal structure of a menu at a safe time (when no-one is - * using it anymore). If called on a master instance, destroys all of the - * slave instances. If called on a non-master instance, just destroys - * that instance. - * - * Results: - * None. - * - * Side effects: - * Everything associated with the menu is freed up. - * - *---------------------------------------------------------------------- - */ - -void -TkDestroyMenu( - TkMenu *menuPtr) /* Info about menu widget. */ -{ - TkMenu *menuInstancePtr; - TkMenuTopLevelList *topLevelListPtr, *nextTopLevelPtr; - - if (menuPtr->menuFlags & MENU_DELETION_PENDING) { - return; - } - - Tcl_Preserve(menuPtr); - - /* - * Now destroy all non-tearoff instances of this menu if this is a parent - * menu. Is this loop safe enough? Are there going to be destroy bindings - * on child menus which kill the parent? If not, we have to do a slightly - * more complex scheme. - */ - - menuPtr->menuFlags |= MENU_DELETION_PENDING; - if (menuPtr->menuRefPtr != NULL) { - /* - * If any toplevel widgets have this menu as their menubar, the - * geometry of the window may have to be recalculated. - */ - - topLevelListPtr = menuPtr->menuRefPtr->topLevelListPtr; - while (topLevelListPtr != NULL) { - nextTopLevelPtr = topLevelListPtr->nextPtr; - TkpSetWindowMenuBar(topLevelListPtr->tkwin, NULL); - topLevelListPtr = nextTopLevelPtr; - } - } - if (menuPtr->masterMenuPtr == menuPtr) { - while (menuPtr->nextInstancePtr != NULL) { - menuInstancePtr = menuPtr->nextInstancePtr; - menuPtr->nextInstancePtr = menuInstancePtr->nextInstancePtr; - if (menuInstancePtr->tkwin != NULL) { - Tk_Window tkwin = menuInstancePtr->tkwin; - - /* - * Note: it may be desirable to NULL out the tkwin field of - * menuInstancePtr here: - * menuInstancePtr->tkwin = NULL; - */ - - Tk_DestroyWindow(tkwin); - } - } - } - - DestroyMenuInstance(menuPtr); - - Tcl_Release(menuPtr); -} - -/* - *---------------------------------------------------------------------- - * - * UnhookCascadeEntry -- - * - * This entry is removed from the list of entries that point to the - * cascade menu. This is done in preparation for changing the menu that - * this entry points to. - * - * At the end of this function, the menu entry no longer contains a - * reference to a 'TkMenuReferences' structure, and therefore no such - * structure contains a reference to this menu entry either. - * - * Results: - * None - * - * Side effects: - * The appropriate lists are modified. - * - *---------------------------------------------------------------------- - */ - -static void -UnhookCascadeEntry( - TkMenuEntry *mePtr) /* The cascade entry we are removing from the - * cascade list. */ -{ - TkMenuEntry *cascadeEntryPtr; - TkMenuEntry *prevCascadePtr; - TkMenuReferences *menuRefPtr; - - menuRefPtr = mePtr->childMenuRefPtr; - if (menuRefPtr == NULL) { - return; - } - - cascadeEntryPtr = menuRefPtr->parentEntryPtr; - if (cascadeEntryPtr == NULL) { - TkFreeMenuReferences(menuRefPtr); - mePtr->childMenuRefPtr = NULL; - return; - } - - /* - * Singularly linked list deletion. The two special cases are 1. one - * element; 2. The first element is the one we want. - */ - - if (cascadeEntryPtr == mePtr) { - if (cascadeEntryPtr->nextCascadePtr == NULL) { - /* - * This is the last menu entry which points to this menu, so we - * need to clear out the list pointer in the cascade itself. - */ - - menuRefPtr->parentEntryPtr = NULL; - - /* - * The original field is set to zero below, after it is freed. - */ - - TkFreeMenuReferences(menuRefPtr); - } else { - menuRefPtr->parentEntryPtr = cascadeEntryPtr->nextCascadePtr; - } - mePtr->nextCascadePtr = NULL; - } else { - for (prevCascadePtr = cascadeEntryPtr, - cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr; - cascadeEntryPtr != NULL; - prevCascadePtr = cascadeEntryPtr, - cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { - if (cascadeEntryPtr == mePtr){ - prevCascadePtr->nextCascadePtr = - cascadeEntryPtr->nextCascadePtr; - cascadeEntryPtr->nextCascadePtr = NULL; - break; - } - } - mePtr->nextCascadePtr = NULL; - } - mePtr->childMenuRefPtr = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * DestroyMenuEntry -- - * - * This function is invoked by Tcl_EventuallyFree or Tcl_Release to clean - * up the internal structure of a menu entry at a safe time (when no-one - * is using it anymore). - * - * Results: - * None. - * - * Side effects: - * Everything associated with the menu entry is freed. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyMenuEntry( - void *memPtr) /* Pointer to entry to be freed. */ -{ - register TkMenuEntry *mePtr = memPtr; - TkMenu *menuPtr = mePtr->menuPtr; - - if (menuPtr->postedCascade == mePtr) { - /* - * Ignore errors while unposting the menu, since it's possible that - * the menu has already been deleted and the unpost will generate an - * error. - */ - - TkPostSubmenu(menuPtr->interp, menuPtr, NULL); - } - - /* - * Free up all the stuff that requires special handling, then let - * Tk_FreeConfigOptions handle all the standard option-related stuff. - */ - - if (mePtr->type == CASCADE_ENTRY) { - if (menuPtr->masterMenuPtr != menuPtr) { - TkMenu *destroyThis = NULL; - TkMenuReferences *menuRefPtr = mePtr->childMenuRefPtr; - - /* - * The menu as a whole is a clone. We must delete the clone of the - * cascaded menu for the particular entry we are destroying. - */ - - if (menuRefPtr != NULL) { - destroyThis = menuRefPtr->menuPtr; - - /* - * But only if it is a clone. What can happen is that we are - * in the middle of deleting a menu and this menu pointer has - * already been reset to point to the original menu. In that - * case we have nothing special to do. - */ - - if ((destroyThis != NULL) - && (destroyThis->masterMenuPtr == destroyThis)) { - destroyThis = NULL; - } - } - UnhookCascadeEntry(mePtr); - menuRefPtr = mePtr->childMenuRefPtr; - if (menuRefPtr != NULL) { - if (menuRefPtr->menuPtr == destroyThis) { - menuRefPtr->menuPtr = NULL; - } - } - if (destroyThis != NULL) { - TkDestroyMenu(destroyThis); - } - } else { - UnhookCascadeEntry(mePtr); - } - } - if (mePtr->image != NULL) { - Tk_FreeImage(mePtr->image); - } - if (mePtr->selectImage != NULL) { - Tk_FreeImage(mePtr->selectImage); - } - if (((mePtr->type == CHECK_BUTTON_ENTRY) - || (mePtr->type == RADIO_BUTTON_ENTRY)) - && (mePtr->namePtr != NULL)) { - const char *varName = Tcl_GetString(mePtr->namePtr); - - Tcl_UntraceVar2(menuPtr->interp, varName, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - MenuVarProc, mePtr); - } - TkpDestroyMenuEntry(mePtr); - TkMenuEntryFreeDrawOptions(mePtr); - Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable, menuPtr->tkwin); - ckfree(mePtr); -} - -/* - *--------------------------------------------------------------------------- - * - * MenuWorldChanged -- - * - * This function is called when the world has changed in some way (such - * as the fonts in the system changing) and the widget needs to recompute - * all its graphics contexts and determine its new geometry. - * - * Results: - * None. - * - * Side effects: - * Menu will be relayed out and redisplayed. - * - *--------------------------------------------------------------------------- - */ - -static void -MenuWorldChanged( - ClientData instanceData) /* Information about widget. */ -{ - TkMenu *menuPtr = instanceData; - int i; - - TkMenuConfigureDrawOptions(menuPtr); - for (i = 0; i < menuPtr->numEntries; i++) { - TkMenuConfigureEntryDrawOptions(menuPtr->entries[i], - menuPtr->entries[i]->index); - TkpConfigureMenuEntry(menuPtr->entries[i]); - } - TkEventuallyRecomputeMenu(menuPtr); -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureMenu -- - * - * This function is called to process an argv/argc list, plus the Tk - * option database, in order to configure (or reconfigure) a menu widget. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is returned, - * then the interp's result contains an error message. - * - * Side effects: - * Configuration information, such as colors, font, etc. get set for - * menuPtr; old resources get freed, if there were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureMenu( - Tcl_Interp *interp, /* Used for error reporting. */ - register TkMenu *menuPtr, /* Information about widget; may or may not - * already have values for some fields. */ - int objc, /* Number of valid entries in argv. */ - Tcl_Obj *const objv[]) /* Arguments. */ -{ - int i; - TkMenu *menuListPtr, *cleanupPtr; - int result; - ThreadSpecificData *tsdPtr = - Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); - - for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL; - menuListPtr = menuListPtr->nextInstancePtr) { - menuListPtr->errorStructPtr = ckalloc(sizeof(Tk_SavedOptions)); - result = Tk_SetOptions(interp, (char *) menuListPtr, - tsdPtr->menuOptionTable, objc, objv, - menuListPtr->tkwin, menuListPtr->errorStructPtr, NULL); - if (result != TCL_OK) { - for (cleanupPtr = menuPtr->masterMenuPtr; - cleanupPtr != menuListPtr; - cleanupPtr = cleanupPtr->nextInstancePtr) { - Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr); - ckfree(cleanupPtr->errorStructPtr); - cleanupPtr->errorStructPtr = NULL; - } - if (menuListPtr->errorStructPtr != NULL) { - Tk_RestoreSavedOptions(menuListPtr->errorStructPtr); - ckfree(menuListPtr->errorStructPtr); - menuListPtr->errorStructPtr = NULL; - } - return TCL_ERROR; - } - - /* - * When a menu is created, the type is in all of the arguments to the - * menu command. Let Tk_ConfigureWidget take care of parsing them, and - * then set the type after we can look at the type string. Once set, a - * menu's type cannot be changed - */ - - if (menuListPtr->menuType == UNKNOWN_TYPE) { - Tcl_GetIndexFromObjStruct(NULL, menuListPtr->menuTypePtr, - menuTypeStrings, sizeof(char *), NULL, 0, &menuListPtr->menuType); - - /* - * Configure the new window to be either a pop-up menu or a - * tear-off menu. We don't do this for menubars since they are not - * toplevel windows. Also, since this gets called before CloneMenu - * has a chance to set the menuType field, we have to look at the - * menuTypeName field to tell that this is a menu bar. - */ - - if (menuListPtr->menuType == MASTER_MENU) { - int typeFlag = TK_MAKE_MENU_POPUP; - Tk_Window tkwin = menuPtr->tkwin; - - /* - * Work out if we are the child of a menubar or a popup. - */ - - while (1) { - Tk_Window parent = Tk_Parent(tkwin); - - if (Tk_Class(parent) != Tk_Class(menuPtr->tkwin)) { - break; - } - tkwin = parent; - } - if (((TkMenu *) tkwin)->menuType == MENUBAR) { - typeFlag = TK_MAKE_MENU_DROPDOWN; - } - - TkpMakeMenuWindow(menuListPtr->tkwin, typeFlag); - } else if (menuListPtr->menuType == TEAROFF_MENU) { - TkpMakeMenuWindow(menuListPtr->tkwin, TK_MAKE_MENU_TEAROFF); - } - } - - /* - * Depending on the -tearOff option, make sure that there is or isn't - * an initial tear-off entry at the beginning of the menu. - */ - - if (menuListPtr->tearoff) { - if ((menuListPtr->numEntries == 0) - || (menuListPtr->entries[0]->type != TEAROFF_ENTRY)) { - if (MenuNewEntry(menuListPtr, 0, TEAROFF_ENTRY) == NULL) { - for (cleanupPtr = menuPtr->masterMenuPtr; - cleanupPtr != menuListPtr; - cleanupPtr = cleanupPtr->nextInstancePtr) { - Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr); - ckfree(cleanupPtr->errorStructPtr); - cleanupPtr->errorStructPtr = NULL; - } - if (menuListPtr->errorStructPtr != NULL) { - Tk_RestoreSavedOptions(menuListPtr->errorStructPtr); - ckfree(menuListPtr->errorStructPtr); - menuListPtr->errorStructPtr = NULL; - } - return TCL_ERROR; - } - } - } else if ((menuListPtr->numEntries > 0) - && (menuListPtr->entries[0]->type == TEAROFF_ENTRY)) { - int i; - - Tcl_EventuallyFree(menuListPtr->entries[0], (Tcl_FreeProc *) DestroyMenuEntry); - - for (i = 0; i < menuListPtr->numEntries - 1; i++) { - menuListPtr->entries[i] = menuListPtr->entries[i + 1]; - menuListPtr->entries[i]->index = i; - } - menuListPtr->numEntries--; - if (menuListPtr->numEntries == 0) { - ckfree(menuListPtr->entries); - menuListPtr->entries = NULL; - } - } - - TkMenuConfigureDrawOptions(menuListPtr); - - /* - * After reconfiguring a menu, we need to reconfigure all of the - * entries in the menu, since some of the things in the children (such - * as graphics contexts) may have to change to reflect changes in the - * parent. - */ - - for (i = 0; i < menuListPtr->numEntries; i++) { - TkMenuEntry *mePtr; - - mePtr = menuListPtr->entries[i]; - ConfigureMenuEntry(mePtr, 0, NULL); - } - - TkEventuallyRecomputeMenu(menuListPtr); - } - - for (cleanupPtr = menuPtr->masterMenuPtr; cleanupPtr != NULL; - cleanupPtr = cleanupPtr->nextInstancePtr) { - Tk_FreeSavedOptions(cleanupPtr->errorStructPtr); - ckfree(cleanupPtr->errorStructPtr); - cleanupPtr->errorStructPtr = NULL; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PostProcessEntry -- - * - * This is called by ConfigureMenuEntry to do all of the configuration - * after Tk_SetOptions is called. This is separate so that error handling - * is easier. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is returned, - * then the interp's result contains an error message. - * - * Side effects: - * Configuration information such as label and accelerator get set for - * mePtr; old resources get freed, if there were any. - * - *---------------------------------------------------------------------- - */ - -static int -PostProcessEntry( - TkMenuEntry *mePtr) /* The entry we are configuring. */ -{ - TkMenu *menuPtr = mePtr->menuPtr; - int index = mePtr->index; - const char *name; - Tk_Image image; - - /* - * The code below handles special configuration stuff not taken care of by - * Tk_ConfigureWidget, such as special processing for defaults, sizing - * strings, graphics contexts, etc. - */ - - if (mePtr->labelPtr == NULL) { - mePtr->labelLength = 0; - } else { - (void)Tcl_GetStringFromObj(mePtr->labelPtr, &mePtr->labelLength); - } - if (mePtr->accelPtr == NULL) { - mePtr->accelLength = 0; - } else { - (void)Tcl_GetStringFromObj(mePtr->accelPtr, &mePtr->accelLength); - } - - /* - * If this is a cascade entry, the platform-specific data of the child - * menu has to be updated. Also, the links that point to parents and - * cascades have to be updated. - */ - - if ((mePtr->type == CASCADE_ENTRY) && (mePtr->namePtr != NULL)) { - TkMenuEntry *cascadeEntryPtr; - int alreadyThere; - TkMenuReferences *menuRefPtr; - char *oldHashKey = NULL; /* Initialization only needed to - * prevent compiler warning. */ - - /* - * This is a cascade entry. If the menu that the cascade entry is - * pointing to has changed, we need to remove this entry from the list - * of entries pointing to the old menu, and add a cascade reference to - * the list of entries pointing to the new menu. - * - * BUG: We are not recloning for special case #3 yet. - */ - - name = Tcl_GetString(mePtr->namePtr); - if (mePtr->childMenuRefPtr != NULL) { - oldHashKey = Tcl_GetHashKey(TkGetMenuHashTable(menuPtr->interp), - mePtr->childMenuRefPtr->hashEntryPtr); - if (strcmp(oldHashKey, name) != 0) { - UnhookCascadeEntry(mePtr); - } - } - - if ((mePtr->childMenuRefPtr == NULL) - || (strcmp(oldHashKey, name) != 0)) { - menuRefPtr = TkCreateMenuReferences(menuPtr->interp, name); - mePtr->childMenuRefPtr = menuRefPtr; - - if (menuRefPtr->parentEntryPtr == NULL) { - menuRefPtr->parentEntryPtr = mePtr; - } else { - alreadyThere = 0; - for (cascadeEntryPtr = menuRefPtr->parentEntryPtr; - cascadeEntryPtr != NULL; - cascadeEntryPtr = - cascadeEntryPtr->nextCascadePtr) { - if (cascadeEntryPtr == mePtr) { - alreadyThere = 1; - break; - } - } - - /* - * Put the item at the front of the list. - */ - - if (!alreadyThere) { - mePtr->nextCascadePtr = menuRefPtr->parentEntryPtr; - menuRefPtr->parentEntryPtr = mePtr; - } - } - } - } - - if (TkMenuConfigureEntryDrawOptions(mePtr, index) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Get the images for the entry, if there are any. Allocate the new images - * before freeing the old ones, so that the reference counts don't go to - * zero and cause image data to be discarded. - */ - - if (mePtr->imagePtr != NULL) { - const char *imageString = Tcl_GetString(mePtr->imagePtr); - - image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, imageString, - TkMenuImageProc, mePtr); - if (image == NULL) { - return TCL_ERROR; - } - } else { - image = NULL; - } - if (mePtr->image != NULL) { - Tk_FreeImage(mePtr->image); - } - mePtr->image = image; - if (mePtr->selectImagePtr != NULL) { - const char *selectImageString = Tcl_GetString(mePtr->selectImagePtr); - - image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, selectImageString, - TkMenuSelectImageProc, mePtr); - if (image == NULL) { - return TCL_ERROR; - } - } else { - image = NULL; - } - if (mePtr->selectImage != NULL) { - Tk_FreeImage(mePtr->selectImage); - } - mePtr->selectImage = image; - - if ((mePtr->type == CHECK_BUTTON_ENTRY) - || (mePtr->type == RADIO_BUTTON_ENTRY)) { - Tcl_Obj *valuePtr; - const char *name; - - if (mePtr->namePtr == NULL) { - if (mePtr->labelPtr == NULL) { - mePtr->namePtr = NULL; - } else { - mePtr->namePtr = Tcl_DuplicateObj(mePtr->labelPtr); - Tcl_IncrRefCount(mePtr->namePtr); - } - } - if (mePtr->onValuePtr == NULL) { - if (mePtr->labelPtr == NULL) { - mePtr->onValuePtr = NULL; - } else { - mePtr->onValuePtr = Tcl_DuplicateObj(mePtr->labelPtr); - Tcl_IncrRefCount(mePtr->onValuePtr); - } - } - - /* - * Select the entry if the associated variable has the appropriate - * value, initialize the variable if it doesn't exist, then set a - * trace on the variable to monitor future changes to its value. - */ - - if (mePtr->namePtr != NULL) { - valuePtr = Tcl_ObjGetVar2(menuPtr->interp, mePtr->namePtr, NULL, - TCL_GLOBAL_ONLY); - } else { - valuePtr = NULL; - } - mePtr->entryFlags &= ~ENTRY_SELECTED; - if (valuePtr != NULL) { - if (mePtr->onValuePtr != NULL) { - const char *value = Tcl_GetString(valuePtr); - const char *onValue = Tcl_GetString(mePtr->onValuePtr); - - if (strcmp(value, onValue) == 0) { - mePtr->entryFlags |= ENTRY_SELECTED; - } - } - } else { - if (mePtr->namePtr != NULL) { - Tcl_ObjSetVar2(menuPtr->interp, mePtr->namePtr, NULL, - (mePtr->type == CHECK_BUTTON_ENTRY) - ? mePtr->offValuePtr : Tcl_NewObj(), TCL_GLOBAL_ONLY); - } - } - if (mePtr->namePtr != NULL) { - name = Tcl_GetString(mePtr->namePtr); - Tcl_TraceVar2(menuPtr->interp, name, - NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - MenuVarProc, mePtr); - } - } - - if (TkpConfigureMenuEntry(mePtr) != TCL_OK) { - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureMenuEntry -- - * - * This function is called to process an argv/argc list in order to - * configure (or reconfigure) one entry in a menu. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is returned, - * then the interp's result contains an error message. - * - * Side effects: - * Configuration information such as label and accelerator get set for - * mePtr; old resources get freed, if there were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureMenuEntry( - register TkMenuEntry *mePtr,/* Information about menu entry; may or may - * not already have values for some fields. */ - int objc, /* Number of valid entries in argv. */ - Tcl_Obj *const objv[]) /* Arguments. */ -{ - TkMenu *menuPtr = mePtr->menuPtr; - Tk_SavedOptions errorStruct; - int result; - - /* - * If this entry is a check button or radio button, then remove its old - * trace function. - */ - - if ((mePtr->namePtr != NULL) - && ((mePtr->type == CHECK_BUTTON_ENTRY) - || (mePtr->type == RADIO_BUTTON_ENTRY))) { - const char *name = Tcl_GetString(mePtr->namePtr); - - Tcl_UntraceVar2(menuPtr->interp, name, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - MenuVarProc, mePtr); - } - - result = TCL_OK; - if (menuPtr->tkwin != NULL) { - if (Tk_SetOptions(menuPtr->interp, (char *) mePtr, - mePtr->optionTable, objc, objv, menuPtr->tkwin, - &errorStruct, NULL) != TCL_OK) { - return TCL_ERROR; - } - result = PostProcessEntry(mePtr); - if (result != TCL_OK) { - Tk_RestoreSavedOptions(&errorStruct); - PostProcessEntry(mePtr); - } - Tk_FreeSavedOptions(&errorStruct); - } - - TkEventuallyRecomputeMenu(menuPtr); - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureMenuCloneEntries -- - * - * Calls ConfigureMenuEntry for each menu in the clone chain. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is returned, - * then the interp's result contains an error message. - * - * Side effects: - * Configuration information such as label and accelerator get set for - * mePtr; old resources get freed, if there were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureMenuCloneEntries( - Tcl_Interp *interp, /* Used for error reporting. */ - TkMenu *menuPtr, /* Information about whole menu. */ - int index, /* Index of mePtr within menuPtr's entries. */ - int objc, /* Number of valid entries in argv. */ - Tcl_Obj *const objv[]) /* Arguments. */ -{ - TkMenuEntry *mePtr; - TkMenu *menuListPtr; - int cascadeEntryChanged = 0; - TkMenuReferences *oldCascadeMenuRefPtr, *cascadeMenuRefPtr = NULL; - Tcl_Obj *oldCascadePtr = NULL; - const char *newCascadeName; - - /* - * Cascades are kind of tricky here. This is special case #3 in the - * comment at the top of this file. Basically, if a menu is the master - * menu of a clone chain, and has an entry with a cascade menu, the clones - * of the menu will point to clones of the cascade menu. We have to - * destroy the clones of the cascades, clone the new cascade menu, and - * configure the entry to point to the new clone. - */ - - mePtr = menuPtr->masterMenuPtr->entries[index]; - if (mePtr->type == CASCADE_ENTRY) { - oldCascadePtr = mePtr->namePtr; - if (oldCascadePtr != NULL) { - Tcl_IncrRefCount(oldCascadePtr); - } - } - - if (ConfigureMenuEntry(mePtr, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - - if (mePtr->type == CASCADE_ENTRY) { - const char *oldCascadeName; - - if (mePtr->namePtr != NULL) { - newCascadeName = Tcl_GetString(mePtr->namePtr); - } else { - newCascadeName = NULL; - } - - if ((oldCascadePtr == NULL) && (mePtr->namePtr == NULL)) { - cascadeEntryChanged = 0; - } else if (((oldCascadePtr == NULL) && (mePtr->namePtr != NULL)) - || ((oldCascadePtr != NULL) - && (mePtr->namePtr == NULL))) { - cascadeEntryChanged = 1; - } else { - oldCascadeName = Tcl_GetString(oldCascadePtr); - cascadeEntryChanged = (strcmp(oldCascadeName, newCascadeName) - != 0); - } - if (oldCascadePtr != NULL) { - Tcl_DecrRefCount(oldCascadePtr); - } - } - - if (cascadeEntryChanged) { - if (mePtr->namePtr != NULL) { - newCascadeName = Tcl_GetString(mePtr->namePtr); - cascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp, - newCascadeName); - } - } - - for (menuListPtr = menuPtr->masterMenuPtr->nextInstancePtr; - menuListPtr != NULL; - menuListPtr = menuListPtr->nextInstancePtr) { - - mePtr = menuListPtr->entries[index]; - - if (cascadeEntryChanged && (mePtr->namePtr != NULL)) { - oldCascadeMenuRefPtr = TkFindMenuReferencesObj(menuPtr->interp, - mePtr->namePtr); - - if ((oldCascadeMenuRefPtr != NULL) - && (oldCascadeMenuRefPtr->menuPtr != NULL)) { - RecursivelyDeleteMenu(oldCascadeMenuRefPtr->menuPtr); - } - } - - if (ConfigureMenuEntry(mePtr, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - - if (cascadeEntryChanged && (mePtr->namePtr != NULL)) { - if (cascadeMenuRefPtr && cascadeMenuRefPtr->menuPtr != NULL) { - Tcl_Obj *newObjv[2]; - Tcl_Obj *newCloneNamePtr; - Tcl_Obj *pathNamePtr = Tcl_NewStringObj( - Tk_PathName(menuListPtr->tkwin), -1); - Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1); - Tcl_Obj *menuObjPtr = Tcl_NewStringObj("-menu", -1); - - Tcl_IncrRefCount(pathNamePtr); - newCloneNamePtr = TkNewMenuName(menuPtr->interp, - pathNamePtr, - cascadeMenuRefPtr->menuPtr); - Tcl_IncrRefCount(newCloneNamePtr); - Tcl_IncrRefCount(normalPtr); - CloneMenu(cascadeMenuRefPtr->menuPtr, newCloneNamePtr, - normalPtr); - - newObjv[0] = menuObjPtr; - newObjv[1] = newCloneNamePtr; - Tcl_IncrRefCount(menuObjPtr); - ConfigureMenuEntry(mePtr, 2, newObjv); - Tcl_DecrRefCount(newCloneNamePtr); - Tcl_DecrRefCount(pathNamePtr); - Tcl_DecrRefCount(normalPtr); - Tcl_DecrRefCount(menuObjPtr); - } - } - } - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * TkGetMenuIndex -- - * - * Parse a textual index into a menu and return the numerical index of - * the indicated entry. - * - * Results: - * A standard Tcl result. If all went well, then *indexPtr is filled in - * with the entry index corresponding to string (ranges from -1 to the - * number of entries in the menu minus one). Otherwise an error message - * is left in the interp's result. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -int -TkGetMenuIndex( - Tcl_Interp *interp, /* For error messages. */ - TkMenu *menuPtr, /* Menu for which the index is being - * specified. */ - Tcl_Obj *objPtr, /* Specification of an entry in menu. See - * manual entry for valid .*/ - int lastOK, /* Non-zero means its OK to return index just - * *after* last entry. */ - int *indexPtr) /* Where to store converted index. */ -{ - int i; - const char *string = Tcl_GetString(objPtr); - - if ((string[0] == 'a') && (strcmp(string, "active") == 0)) { - *indexPtr = menuPtr->active; - goto success; - } - - if (((string[0] == 'l') && (strcmp(string, "last") == 0)) - || ((string[0] == 'e') && (strcmp(string, "end") == 0))) { - *indexPtr = menuPtr->numEntries - ((lastOK) ? 0 : 1); - goto success; - } - - if ((string[0] == 'n') && (strcmp(string, "none") == 0)) { - *indexPtr = -1; - goto success; - } - - if (string[0] == '@') { - if (GetIndexFromCoords(interp, menuPtr, string, indexPtr) - == TCL_OK) { - goto success; - } - } - - if (isdigit(UCHAR(string[0]))) { - if (Tcl_GetInt(interp, string, &i) == TCL_OK) { - if (i >= menuPtr->numEntries) { - if (lastOK) { - i = menuPtr->numEntries; - } else { - i = menuPtr->numEntries-1; - } - } else if (i < 0) { - i = -1; - } - *indexPtr = i; - goto success; - } - Tcl_ResetResult(interp); - } - - for (i = 0; i < menuPtr->numEntries; i++) { - Tcl_Obj *labelPtr = menuPtr->entries[i]->labelPtr; - const char *label = (labelPtr == NULL) ? NULL : Tcl_GetString(labelPtr); - - if ((label != NULL) && (Tcl_StringMatch(label, string))) { - *indexPtr = i; - goto success; - } - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad menu entry index \"%s\"", string)); - Tcl_SetErrorCode(interp, "TK", "MENU", "INDEX", NULL); - return TCL_ERROR; - - success: - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * MenuCmdDeletedProc -- - * - * This function is invoked when a widget command is deleted. If the - * widget isn't already in the process of being destroyed, this command - * destroys it. - * - * Results: - * None. - * - * Side effects: - * The widget is destroyed. - * - *---------------------------------------------------------------------- - */ - -static void -MenuCmdDeletedProc( - ClientData clientData) /* Pointer to widget record for widget. */ -{ - TkMenu *menuPtr = clientData; - Tk_Window tkwin = menuPtr->tkwin; - - /* - * This function could be invoked either because the window was destroyed - * and the command was then deleted (in which case tkwin is NULL) or - * because the command was deleted, and then this function destroys the - * widget. - */ - - if (tkwin != NULL) { - /* - * Note: it may be desirable to NULL out the tkwin field of menuPtr - * here: - * menuPtr->tkwin = NULL; - */ - - Tk_DestroyWindow(tkwin); - } -} - -/* - *---------------------------------------------------------------------- - * - * MenuNewEntry -- - * - * This function allocates and initializes a new menu entry. - * - * Results: - * The return value is a pointer to a new menu entry structure, which has - * been malloc-ed, initialized, and entered into the entry array for the - * menu. - * - * Side effects: - * Storage gets allocated. - * - *---------------------------------------------------------------------- - */ - -static TkMenuEntry * -MenuNewEntry( - TkMenu *menuPtr, /* Menu that will hold the new entry. */ - int index, /* Where in the menu the new entry is to - * go. */ - int type) /* The type of the new entry. */ -{ - TkMenuEntry *mePtr; - TkMenuEntry **newEntries; - int i; - ThreadSpecificData *tsdPtr = - Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); - - /* - * Create a new array of entries with an empty slot for the new entry. - */ - - newEntries = ckalloc((menuPtr->numEntries+1) * sizeof(TkMenuEntry *)); - for (i = 0; i < index; i++) { - newEntries[i] = menuPtr->entries[i]; - } - for (; i < menuPtr->numEntries; i++) { - newEntries[i+1] = menuPtr->entries[i]; - newEntries[i+1]->index = i + 1; - } - if (menuPtr->numEntries != 0) { - ckfree(menuPtr->entries); - } - menuPtr->entries = newEntries; - menuPtr->numEntries++; - mePtr = ckalloc(sizeof(TkMenuEntry)); - menuPtr->entries[index] = mePtr; - mePtr->type = type; - mePtr->optionTable = tsdPtr->entryOptionTables[type]; - mePtr->menuPtr = menuPtr; - mePtr->labelPtr = NULL; - mePtr->labelLength = 0; - mePtr->underline = -1; - mePtr->bitmapPtr = NULL; - mePtr->imagePtr = NULL; - mePtr->image = NULL; - mePtr->selectImagePtr = NULL; - mePtr->selectImage = NULL; - mePtr->accelPtr = NULL; - mePtr->accelLength = 0; - mePtr->state = ENTRY_DISABLED; - mePtr->borderPtr = NULL; - mePtr->fgPtr = NULL; - mePtr->activeBorderPtr = NULL; - mePtr->activeFgPtr = NULL; - mePtr->fontPtr = NULL; - mePtr->indicatorOn = 0; - mePtr->indicatorFgPtr = NULL; - mePtr->columnBreak = 0; - mePtr->hideMargin = 0; - mePtr->commandPtr = NULL; - mePtr->namePtr = NULL; - mePtr->childMenuRefPtr = NULL; - mePtr->onValuePtr = NULL; - mePtr->offValuePtr = NULL; - mePtr->entryFlags = 0; - mePtr->index = index; - mePtr->nextCascadePtr = NULL; - if (Tk_InitOptions(menuPtr->interp, (char *) mePtr, - mePtr->optionTable, menuPtr->tkwin) != TCL_OK) { - ckfree(mePtr); - return NULL; - } - TkMenuInitializeEntryDrawingFields(mePtr); - if (TkpMenuNewEntry(mePtr) != TCL_OK) { - Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable, - menuPtr->tkwin); - ckfree(mePtr); - return NULL; - } - - return mePtr; -} - -/* - *---------------------------------------------------------------------- - * - * MenuAddOrInsert -- - * - * This function does all of the work of the "add" and "insert" widget - * commands, allowing the code for these to be shared. - * - * Results: - * A standard Tcl return value. - * - * Side effects: - * A new menu entry is created in menuPtr. - * - *---------------------------------------------------------------------- - */ - -static int -MenuAddOrInsert( - Tcl_Interp *interp, /* Used for error reporting. */ - TkMenu *menuPtr, /* Widget in which to create new entry. */ - Tcl_Obj *indexPtr, /* Object describing index at which to insert. - * NULL means insert at end. */ - int objc, /* Number of elements in objv. */ - Tcl_Obj *const objv[]) /* Arguments to command: first arg is type of - * entry, others are config options. */ -{ - int type, index; - TkMenuEntry *mePtr; - TkMenu *menuListPtr; - - if (indexPtr != NULL) { - if (TkGetMenuIndex(interp, menuPtr, indexPtr, 1, &index) != TCL_OK) { - return TCL_ERROR; - } - } else { - index = menuPtr->numEntries; - } - if (index < 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\"", Tcl_GetString(indexPtr))); - Tcl_SetErrorCode(interp, "TK", "MENU", "INDEX", NULL); - return TCL_ERROR; - } - if (menuPtr->tearoff && (index == 0)) { - index = 1; - } - - /* - * Figure out the type of the new entry. - */ - - if (Tcl_GetIndexFromObjStruct(interp, objv[0], menuEntryTypeStrings, - sizeof(char *), "menu entry type", 0, &type) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Now we have to add an entry for every instance related to this menu. - */ - - for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL; - menuListPtr = menuListPtr->nextInstancePtr) { - - mePtr = MenuNewEntry(menuListPtr, index, type); - if (mePtr == NULL) { - return TCL_ERROR; - } - if (ConfigureMenuEntry(mePtr, objc - 1, objv + 1) != TCL_OK) { - TkMenu *errorMenuPtr; - int i; - - for (errorMenuPtr = menuPtr->masterMenuPtr; - errorMenuPtr != NULL; - errorMenuPtr = errorMenuPtr->nextInstancePtr) { - Tcl_EventuallyFree(errorMenuPtr->entries[index], - (Tcl_FreeProc *) DestroyMenuEntry); - for (i = index; i < errorMenuPtr->numEntries - 1; i++) { - errorMenuPtr->entries[i] = errorMenuPtr->entries[i + 1]; - errorMenuPtr->entries[i]->index = i; - } - errorMenuPtr->numEntries--; - if (errorMenuPtr->numEntries == 0) { - ckfree(errorMenuPtr->entries); - errorMenuPtr->entries = NULL; - } - if (errorMenuPtr == menuListPtr) { - break; - } - } - return TCL_ERROR; - } - - /* - * 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 - * with clones means that the menu that the entry points to has to be - * cloned for every clone the master menu has. This is special case #2 - * in the comment at the top of this file. - */ - - if ((menuPtr != menuListPtr) && (type == CASCADE_ENTRY)) { - if ((mePtr->namePtr != NULL) - && (mePtr->childMenuRefPtr != NULL) - && (mePtr->childMenuRefPtr->menuPtr != NULL)) { - TkMenu *cascadeMenuPtr = - mePtr->childMenuRefPtr->menuPtr->masterMenuPtr; - Tcl_Obj *newCascadePtr, *newObjv[2]; - Tcl_Obj *menuNamePtr = Tcl_NewStringObj("-menu", -1); - Tcl_Obj *windowNamePtr = - Tcl_NewStringObj(Tk_PathName(menuListPtr->tkwin), -1); - Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1); - TkMenuReferences *menuRefPtr; - - Tcl_IncrRefCount(windowNamePtr); - newCascadePtr = TkNewMenuName(menuListPtr->interp, - windowNamePtr, cascadeMenuPtr); - Tcl_IncrRefCount(newCascadePtr); - Tcl_IncrRefCount(normalPtr); - CloneMenu(cascadeMenuPtr, newCascadePtr, normalPtr); - - menuRefPtr = TkFindMenuReferencesObj(menuListPtr->interp, - newCascadePtr); - if (menuRefPtr == NULL) { - Tcl_Panic("CloneMenu failed inside of MenuAddOrInsert"); - } - newObjv[0] = menuNamePtr; - newObjv[1] = newCascadePtr; - Tcl_IncrRefCount(menuNamePtr); - Tcl_IncrRefCount(newCascadePtr); - ConfigureMenuEntry(mePtr, 2, newObjv); - Tcl_DecrRefCount(newCascadePtr); - Tcl_DecrRefCount(menuNamePtr); - Tcl_DecrRefCount(windowNamePtr); - Tcl_DecrRefCount(normalPtr); - } - } - } - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * MenuVarProc -- - * - * This function is invoked when someone changes the state variable - * associated with a radiobutton or checkbutton menu entry. The entry's - * selected state is set to match the value of the variable. - * - * Results: - * NULL is always returned. - * - * Side effects: - * The menu entry may become selected or deselected. - * - *-------------------------------------------------------------- - */ - -static char * -MenuVarProc( - ClientData clientData, /* Information about menu entry. */ - Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *name1, /* First part of variable's name. */ - const char *name2, /* Second part of variable's name. */ - int flags) /* Describes what just happened. */ -{ - TkMenuEntry *mePtr = clientData; - TkMenu *menuPtr; - const char *value; - const char *name, *onValue; - - if (flags & TCL_INTERP_DESTROYED) { - /* - * Do nothing if the interpreter is going away. - */ - - return NULL; - } - - menuPtr = mePtr->menuPtr; - name = Tcl_GetString(mePtr->namePtr); - - /* - * If the variable is being unset, then re-establish the trace. - */ - - if (flags & TCL_TRACE_UNSETS) { - mePtr->entryFlags &= ~ENTRY_SELECTED; - if (flags & TCL_TRACE_DESTROYED) { - Tcl_TraceVar2(interp, name, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - MenuVarProc, clientData); - } - TkpConfigureMenuEntry(mePtr); - TkEventuallyRedrawMenu(menuPtr, NULL); - return NULL; - } - - /* - * Use the value of the variable to update the selected status of the menu - * entry. - */ - - value = Tcl_GetVar2(interp, name, NULL, TCL_GLOBAL_ONLY); - if (value == NULL) { - value = ""; - } - if (mePtr->onValuePtr != NULL) { - onValue = Tcl_GetString(mePtr->onValuePtr); - if (strcmp(value, onValue) == 0) { - if (mePtr->entryFlags & ENTRY_SELECTED) { - return NULL; - } - mePtr->entryFlags |= ENTRY_SELECTED; - } else if (mePtr->entryFlags & ENTRY_SELECTED) { - mePtr->entryFlags &= ~ENTRY_SELECTED; - } else { - return NULL; - } - } else { - return NULL; - } - TkpConfigureMenuEntry(mePtr); - TkEventuallyRedrawMenu(menuPtr, mePtr); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TkActivateMenuEntry -- - * - * This function is invoked to make a particular menu entry the active - * one, deactivating any other entry that might currently be active. - * - * Results: - * The return value is a standard Tcl result (errors can occur while - * posting and unposting submenus). - * - * Side effects: - * Menu entries get redisplayed, and the active entry changes. Submenus - * may get posted and unposted. - * - *---------------------------------------------------------------------- - */ - -int -TkActivateMenuEntry( - register TkMenu *menuPtr, /* Menu in which to activate. */ - int index) /* Index of entry to activate, or -1 to - * deactivate all entries. */ -{ - register TkMenuEntry *mePtr; - int result = TCL_OK; - - if (menuPtr->active >= 0) { - mePtr = menuPtr->entries[menuPtr->active]; - - /* - * Don't change the state unless it's currently active (state might - * already have been changed to disabled). - */ - - if (mePtr->state == ENTRY_ACTIVE) { - mePtr->state = ENTRY_NORMAL; - } - TkEventuallyRedrawMenu(menuPtr, menuPtr->entries[menuPtr->active]); - } - menuPtr->active = index; - if (index >= 0) { - mePtr = menuPtr->entries[index]; - mePtr->state = ENTRY_ACTIVE; - TkEventuallyRedrawMenu(menuPtr, mePtr); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TkPostCommand -- - * - * Execute the postcommand for the given menu. - * - * Results: - * The return value is a standard Tcl result (errors can occur while the - * postcommands are being processed). - * - * Side effects: - * Since commands can get executed while this routine is being executed, - * the entire world can change. - * - *---------------------------------------------------------------------- - */ - -int -TkPostCommand( - TkMenu *menuPtr) -{ - int result; - - /* - * If there is a command for the menu, execute it. This may change the - * size of the menu, so be sure to recompute the menu's geometry if - * needed. - */ - - if (menuPtr->postCommandPtr != NULL) { - Tcl_Obj *postCommandPtr = menuPtr->postCommandPtr; - - Tcl_IncrRefCount(postCommandPtr); - result = Tcl_EvalObjEx(menuPtr->interp, postCommandPtr, - TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(postCommandPtr); - if (result != TCL_OK) { - return result; - } - TkRecomputeMenu(menuPtr); - } - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * CloneMenu -- - * - * Creates a child copy of the menu. It will be inserted into the menu's - * instance chain. All attributes and entry attributes will be - * duplicated. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Allocates storage. After the menu is created, any configuration done - * with this menu or any related one will be reflected in all of them. - * - *-------------------------------------------------------------- - */ - -static int -CloneMenu( - TkMenu *menuPtr, /* The menu we are going to clone. */ - Tcl_Obj *newMenuNamePtr, /* The name to give the new menu. */ - Tcl_Obj *newMenuTypePtr) /* What kind of menu is this, a normal menu a - * menubar, or a tearoff? */ -{ - int returnResult; - int menuType, i; - TkMenuReferences *menuRefPtr; - Tcl_Obj *menuDupCommandArray[4]; - - if (newMenuTypePtr == NULL) { - menuType = MASTER_MENU; - } else { - if (Tcl_GetIndexFromObjStruct(menuPtr->interp, newMenuTypePtr, - menuTypeStrings, sizeof(char *), "menu type", 0, &menuType) != TCL_OK) { - return TCL_ERROR; - } - } - - menuDupCommandArray[0] = Tcl_NewStringObj("tk::MenuDup", -1); - menuDupCommandArray[1] = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1); - menuDupCommandArray[2] = newMenuNamePtr; - if (newMenuTypePtr == NULL) { - menuDupCommandArray[3] = Tcl_NewStringObj("normal", -1); - } else { - menuDupCommandArray[3] = newMenuTypePtr; - } - for (i = 0; i < 4; i++) { - Tcl_IncrRefCount(menuDupCommandArray[i]); - } - Tcl_Preserve(menuPtr); - returnResult = Tcl_EvalObjv(menuPtr->interp, 4, menuDupCommandArray, 0); - for (i = 0; i < 4; i++) { - Tcl_DecrRefCount(menuDupCommandArray[i]); - } - - /* - * Make sure the tcl command actually created the clone. - */ - - if ((returnResult == TCL_OK) && - ((menuRefPtr = TkFindMenuReferencesObj(menuPtr->interp, - newMenuNamePtr)) != NULL) - && (menuPtr->numEntries == menuRefPtr->menuPtr->numEntries)) { - TkMenu *newMenuPtr = menuRefPtr->menuPtr; - Tcl_Obj *newObjv[3]; - int i, numElements; - - /* - * Now put this newly created menu into the parent menu's instance - * chain. - */ - - if (menuPtr->nextInstancePtr == NULL) { - menuPtr->nextInstancePtr = newMenuPtr; - newMenuPtr->masterMenuPtr = menuPtr->masterMenuPtr; - } else { - TkMenu *masterMenuPtr; - - masterMenuPtr = menuPtr->masterMenuPtr; - newMenuPtr->nextInstancePtr = masterMenuPtr->nextInstancePtr; - masterMenuPtr->nextInstancePtr = newMenuPtr; - newMenuPtr->masterMenuPtr = masterMenuPtr; - } - - /* - * Add the master menu's window to the bind tags for this window after - * this window's tag. This is so the user can bind to either this - * clone (which may not be easy to do) or the entire menu clone - * structure. - */ - - newObjv[0] = Tcl_NewStringObj("bindtags", -1); - newObjv[1] = Tcl_NewStringObj(Tk_PathName(newMenuPtr->tkwin), -1); - Tcl_IncrRefCount(newObjv[0]); - Tcl_IncrRefCount(newObjv[1]); - if (Tk_BindtagsObjCmd(newMenuPtr->tkwin, newMenuPtr->interp, 2, - newObjv) == TCL_OK) { - const char *windowName; - Tcl_Obj *bindingsPtr = - Tcl_DuplicateObj(Tcl_GetObjResult(newMenuPtr->interp)); - Tcl_Obj *elementPtr; - - Tcl_IncrRefCount(bindingsPtr); - Tcl_ListObjLength(newMenuPtr->interp, bindingsPtr, &numElements); - for (i = 0; i < numElements; i++) { - Tcl_ListObjIndex(newMenuPtr->interp, bindingsPtr, i, - &elementPtr); - windowName = Tcl_GetString(elementPtr); - if (strcmp(windowName, Tk_PathName(newMenuPtr->tkwin)) - == 0) { - Tcl_Obj *newElementPtr = Tcl_NewStringObj( - Tk_PathName(newMenuPtr->masterMenuPtr->tkwin), -1); - - /* - * The newElementPtr will have its refCount incremented - * here, so we don't need to worry about it any more. - */ - - Tcl_ListObjReplace(menuPtr->interp, bindingsPtr, - i + 1, 0, 1, &newElementPtr); - newObjv[2] = bindingsPtr; - Tk_BindtagsObjCmd(newMenuPtr->tkwin, menuPtr->interp, 3, - newObjv); - break; - } - } - Tcl_DecrRefCount(bindingsPtr); - } - Tcl_DecrRefCount(newObjv[0]); - Tcl_DecrRefCount(newObjv[1]); - Tcl_ResetResult(menuPtr->interp); - - /* - * Clone all of the cascade menus that this menu points to. - */ - - for (i = 0; i < menuPtr->numEntries; i++) { - TkMenuReferences *cascadeRefPtr; - TkMenu *oldCascadePtr; - - if ((menuPtr->entries[i]->type == CASCADE_ENTRY) - && (menuPtr->entries[i]->namePtr != NULL)) { - cascadeRefPtr = - TkFindMenuReferencesObj(menuPtr->interp, - menuPtr->entries[i]->namePtr); - if ((cascadeRefPtr != NULL) && (cascadeRefPtr->menuPtr)) { - Tcl_Obj *windowNamePtr = - Tcl_NewStringObj(Tk_PathName(newMenuPtr->tkwin), - -1); - Tcl_Obj *newCascadePtr; - - oldCascadePtr = cascadeRefPtr->menuPtr; - - Tcl_IncrRefCount(windowNamePtr); - newCascadePtr = TkNewMenuName(menuPtr->interp, - windowNamePtr, oldCascadePtr); - Tcl_IncrRefCount(newCascadePtr); - CloneMenu(oldCascadePtr, newCascadePtr, NULL); - - newObjv[0] = Tcl_NewStringObj("-menu", -1); - newObjv[1] = newCascadePtr; - Tcl_IncrRefCount(newObjv[0]); - ConfigureMenuEntry(newMenuPtr->entries[i], 2, newObjv); - Tcl_DecrRefCount(newObjv[0]); - Tcl_DecrRefCount(newCascadePtr); - Tcl_DecrRefCount(windowNamePtr); - } - } - } - - returnResult = TCL_OK; - } else { - returnResult = TCL_ERROR; - } - Tcl_Release(menuPtr); - return returnResult; -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - * Results: - * Returns TCL_OK or TCL_Error - * - * Side effects: - * yPosition is set to the Y-position of the menu entry. - * - *---------------------------------------------------------------------- - */ - -static int -MenuDoYPosition( - Tcl_Interp *interp, - TkMenu *menuPtr, - Tcl_Obj *objPtr) -{ - int index; - - TkRecomputeMenu(menuPtr); - if (TkGetMenuIndex(interp, menuPtr, objPtr, 0, &index) != TCL_OK) { - goto error; - } - Tcl_ResetResult(interp); - if (index < 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(menuPtr->entries[index]->y)); - } - - return TCL_OK; - - error: - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * GetIndexFromCoords -- - * - * Given a string of the form "@integer", return the menu item - * corresponding to the provided y-coordinate in the menu window. - * - * Results: - * If int is a valid number, *indexPtr will be the number of the - * menuentry that is the correct height. If int is invalid, *indexPtr - * will be unchanged. Returns appropriate Tcl error number. - * - * Side effects: - * If int is invalid, interp's result will be set to NULL. - * - *---------------------------------------------------------------------- - */ - -static int -GetIndexFromCoords( - Tcl_Interp *interp, /* Interpreter of menu. */ - TkMenu *menuPtr, /* The menu we are searching. */ - const char *string, /* The @string we are parsing. */ - int *indexPtr) /* The index of the item that matches. */ -{ - int x, y, i; - const char *p; - char *end; - int x2, borderwidth, max; - - TkRecomputeMenu(menuPtr); - p = string + 1; - y = strtol(p, &end, 0); - if (end == p) { - goto error; - } - Tk_GetPixelsFromObj(interp, menuPtr->tkwin, - menuPtr->borderWidthPtr, &borderwidth); - if (*end == ',') { - x = y; - p = end + 1; - y = strtol(p, &end, 0); - if (end == p) { - goto error; - } - } else { - x = borderwidth; - } - - *indexPtr = -1; - - /* set the width of the final column to the remainder of the window - * being aware of windows that may not be mapped yet. - */ - max = Tk_IsMapped(menuPtr->tkwin) - ? Tk_Width(menuPtr->tkwin) : Tk_ReqWidth(menuPtr->tkwin); - max -= borderwidth; - - for (i = 0; i < menuPtr->numEntries; i++) { - if (menuPtr->entries[i]->entryFlags & ENTRY_LAST_COLUMN) { - x2 = max; - } else { - x2 = menuPtr->entries[i]->x + menuPtr->entries[i]->width; - } - if ((x >= menuPtr->entries[i]->x) && (y >= menuPtr->entries[i]->y) - && (x < x2) - && (y < (menuPtr->entries[i]->y - + menuPtr->entries[i]->height))) { - *indexPtr = i; - break; - } - } - return TCL_OK; - - error: - Tcl_ResetResult(interp); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * RecursivelyDeleteMenu -- - * - * Deletes a menu and any cascades underneath it. Used for deleting - * instances when a menu is no longer being used as a menubar, for - * instance. - * - * Results: - * None. - * - * Side effects: - * Destroys the menu and all cascade menus underneath it. - * - *---------------------------------------------------------------------- - */ - -static void -RecursivelyDeleteMenu( - TkMenu *menuPtr) /* The menubar instance we are deleting. */ -{ - int i; - TkMenuEntry *mePtr; - - /* - * It is not 100% clear that this preserve/release pair is required, but - * we have added them for safety in this very complex code. - */ - - Tcl_Preserve(menuPtr); - - for (i = 0; i < menuPtr->numEntries; i++) { - mePtr = menuPtr->entries[i]; - if ((mePtr->type == CASCADE_ENTRY) - && (mePtr->childMenuRefPtr != NULL) - && (mePtr->childMenuRefPtr->menuPtr != NULL)) { - RecursivelyDeleteMenu(mePtr->childMenuRefPtr->menuPtr); - } - } - if (menuPtr->tkwin != NULL) { - Tk_DestroyWindow(menuPtr->tkwin); - } - - Tcl_Release(menuPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TkNewMenuName -- - * - * Makes a new unique name for a cloned menu. Will be a child of oldName. - * - * Results: - * Returns a char * which has been allocated; caller must free. - * - * Side effects: - * Memory is allocated. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TkNewMenuName( - Tcl_Interp *interp, /* The interp the new name has to live in.*/ - Tcl_Obj *parentPtr, /* The prefix path of the new name. */ - TkMenu *menuPtr) /* The menu we are cloning. */ -{ - Tcl_Obj *resultPtr = NULL; /* Initialization needed only to prevent - * compiler warning. */ - Tcl_Obj *childPtr; - char *destString; - int i; - int doDot; - Tcl_HashTable *nameTablePtr = NULL; - TkWindow *winPtr = (TkWindow *) menuPtr->tkwin; - const char *parentName = Tcl_GetString(parentPtr); - - if (winPtr->mainPtr != NULL) { - nameTablePtr = &(winPtr->mainPtr->nameTable); - } - - doDot = parentName[strlen(parentName) - 1] != '.'; - - childPtr = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1); - for (destString = Tcl_GetString(childPtr); - *destString != '\0'; destString++) { - if (*destString == '.') { - *destString = '#'; - } - } - - for (i = 0; ; i++) { - if (i == 0) { - resultPtr = Tcl_DuplicateObj(parentPtr); - if (doDot) { - Tcl_AppendToObj(resultPtr, ".", -1); - } - Tcl_AppendObjToObj(resultPtr, childPtr); - } else { - Tcl_Obj *intPtr; - - Tcl_DecrRefCount(resultPtr); - resultPtr = Tcl_DuplicateObj(parentPtr); - if (doDot) { - Tcl_AppendToObj(resultPtr, ".", -1); - } - Tcl_AppendObjToObj(resultPtr, childPtr); - intPtr = Tcl_NewIntObj(i); - Tcl_AppendObjToObj(resultPtr, intPtr); - Tcl_DecrRefCount(intPtr); - } - destString = Tcl_GetString(resultPtr); - if ((Tcl_FindCommand(interp, destString, NULL, 0) == NULL) - && ((nameTablePtr == NULL) - || (Tcl_FindHashEntry(nameTablePtr, destString) == NULL))) { - break; - } - } - Tcl_DecrRefCount(childPtr); - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkSetWindowMenuBar -- - * - * Associates a menu with a window. Called by ConfigureFrame in in - * response to a "-menu .foo" configuration option for a top level. - * - * Results: - * None. - * - * Side effects: - * The old menu clones for the menubar are thrown away, and a handler is - * set up to allocate the new ones. - * - *---------------------------------------------------------------------- - */ - -void -TkSetWindowMenuBar( - Tcl_Interp *interp, /* The interpreter the toplevel lives in. */ - Tk_Window tkwin, /* The toplevel window. */ - const char *oldMenuName, /* The name of the menubar previously set in - * this toplevel. NULL means no menu was set - * previously. */ - const char *menuName) /* The name of the new menubar that the - * toplevel needs to be set to. NULL means - * that their is no menu now. */ -{ - TkMenuTopLevelList *topLevelListPtr, *prevTopLevelPtr; - TkMenu *menuPtr; - TkMenuReferences *menuRefPtr; - - /* - * Destroy the menubar instances of the old menu. Take this window out of - * the old menu's top level reference list. - */ - - if (oldMenuName != NULL) { - menuRefPtr = TkFindMenuReferences(interp, oldMenuName); - if (menuRefPtr != NULL) { - /* - * Find the menubar instance that is to be removed. Destroy it and - * all of the cascades underneath it. - */ - - if (menuRefPtr->menuPtr != NULL) { - TkMenu *instancePtr; - - menuPtr = menuRefPtr->menuPtr; - - for (instancePtr = menuPtr->masterMenuPtr; - instancePtr != NULL; - instancePtr = instancePtr->nextInstancePtr) { - if (instancePtr->menuType == MENUBAR - && instancePtr->parentTopLevelPtr == tkwin) { - RecursivelyDeleteMenu(instancePtr); - break; - } - } - } - - /* - * Now we need to remove this toplevel from the list of toplevels - * that reference this menu. - */ - - topLevelListPtr = menuRefPtr->topLevelListPtr; - prevTopLevelPtr = NULL; - - while ((topLevelListPtr != NULL) - && (topLevelListPtr->tkwin != tkwin)) { - prevTopLevelPtr = topLevelListPtr; - topLevelListPtr = topLevelListPtr->nextPtr; - } - - /* - * Now we have found the toplevel reference that matches the - * tkwin; remove this reference from the list. - */ - - if (topLevelListPtr != NULL) { - if (prevTopLevelPtr == NULL) { - menuRefPtr->topLevelListPtr = - menuRefPtr->topLevelListPtr->nextPtr; - } else { - prevTopLevelPtr->nextPtr = topLevelListPtr->nextPtr; - } - ckfree(topLevelListPtr); - TkFreeMenuReferences(menuRefPtr); - } - } - } - - /* - * Now, add the clone references for the new menu. - */ - - if (menuName != NULL && menuName[0] != 0) { - TkMenu *menuBarPtr = NULL; - - menuRefPtr = TkCreateMenuReferences(interp, menuName); - - menuPtr = menuRefPtr->menuPtr; - if (menuPtr != NULL) { - Tcl_Obj *cloneMenuPtr; - TkMenuReferences *cloneMenuRefPtr; - Tcl_Obj *newObjv[4]; - Tcl_Obj *windowNamePtr = Tcl_NewStringObj(Tk_PathName(tkwin), - -1); - Tcl_Obj *menubarPtr = Tcl_NewStringObj("menubar", -1); - - /* - * Clone the menu and all of the cascades underneath it. - */ - - Tcl_IncrRefCount(windowNamePtr); - cloneMenuPtr = TkNewMenuName(interp, windowNamePtr, - menuPtr); - Tcl_IncrRefCount(cloneMenuPtr); - Tcl_IncrRefCount(menubarPtr); - CloneMenu(menuPtr, cloneMenuPtr, menubarPtr); - - cloneMenuRefPtr = TkFindMenuReferencesObj(interp, cloneMenuPtr); - if ((cloneMenuRefPtr != NULL) - && (cloneMenuRefPtr->menuPtr != NULL)) { - Tcl_Obj *cursorPtr = Tcl_NewStringObj("-cursor", -1); - Tcl_Obj *nullPtr = Tcl_NewObj(); - - cloneMenuRefPtr->menuPtr->parentTopLevelPtr = tkwin; - menuBarPtr = cloneMenuRefPtr->menuPtr; - newObjv[0] = cursorPtr; - newObjv[1] = nullPtr; - Tcl_IncrRefCount(cursorPtr); - Tcl_IncrRefCount(nullPtr); - ConfigureMenu(menuPtr->interp, cloneMenuRefPtr->menuPtr, - 2, newObjv); - Tcl_DecrRefCount(cursorPtr); - Tcl_DecrRefCount(nullPtr); - } - - TkpSetWindowMenuBar(tkwin, menuBarPtr); - Tcl_DecrRefCount(cloneMenuPtr); - Tcl_DecrRefCount(menubarPtr); - Tcl_DecrRefCount(windowNamePtr); - } else { - TkpSetWindowMenuBar(tkwin, NULL); - } - - /* - * Add this window to the menu's list of windows that refer to this - * menu. - */ - - topLevelListPtr = ckalloc(sizeof(TkMenuTopLevelList)); - topLevelListPtr->tkwin = tkwin; - topLevelListPtr->nextPtr = menuRefPtr->topLevelListPtr; - menuRefPtr->topLevelListPtr = topLevelListPtr; - } else { - TkpSetWindowMenuBar(tkwin, NULL); - } - TkpSetMainMenubar(interp, tkwin, menuName); -} - -/* - *---------------------------------------------------------------------- - * - * DestroyMenuHashTable -- - * - * Called when an interp is deleted and a menu hash table has been set in - * it. - * - * Results: - * None. - * - * Side effects: - * The hash table is destroyed. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyMenuHashTable( - ClientData clientData, /* The menu hash table we are destroying. */ - Tcl_Interp *interp) /* The interpreter we are destroying. */ -{ - Tcl_DeleteHashTable(clientData); - ckfree(clientData); -} - -/* - *---------------------------------------------------------------------- - * - * TkGetMenuHashTable -- - * - * For a given interp, give back the menu hash table that goes with it. - * If the hash table does not exist, it is created. - * - * Results: - * Returns a hash table pointer. - * - * Side effects: - * A new hash table is created if there were no table in the interp - * originally. - * - *---------------------------------------------------------------------- - */ - -Tcl_HashTable * -TkGetMenuHashTable( - Tcl_Interp *interp) /* The interp we need the hash table in.*/ -{ - Tcl_HashTable *menuTablePtr = - Tcl_GetAssocData(interp, MENU_HASH_KEY, NULL); - - if (menuTablePtr == NULL) { - menuTablePtr = ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(menuTablePtr, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, MENU_HASH_KEY, DestroyMenuHashTable, - menuTablePtr); - } - return menuTablePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkCreateMenuReferences -- - * - * Given a pathname, gives back a pointer to a TkMenuReferences - * structure. If a reference is not already in the hash table, one is - * created. - * - * Results: - * Returns a pointer to a menu reference structure. Should not be freed - * by calller; when a field of the reference is cleared, - * TkFreeMenuReferences should be called. - * - * Side effects: - * A new hash table entry is created if there were no references to the - * menu originally. - * - *---------------------------------------------------------------------- - */ - -TkMenuReferences * -TkCreateMenuReferences( - Tcl_Interp *interp, - const char *pathName) /* The path of the menu widget. */ -{ - Tcl_HashEntry *hashEntryPtr; - TkMenuReferences *menuRefPtr; - int newEntry; - Tcl_HashTable *menuTablePtr = TkGetMenuHashTable(interp); - - hashEntryPtr = Tcl_CreateHashEntry(menuTablePtr, pathName, &newEntry); - if (newEntry) { - menuRefPtr = ckalloc(sizeof(TkMenuReferences)); - menuRefPtr->menuPtr = NULL; - menuRefPtr->topLevelListPtr = NULL; - menuRefPtr->parentEntryPtr = NULL; - menuRefPtr->hashEntryPtr = hashEntryPtr; - Tcl_SetHashValue(hashEntryPtr, menuRefPtr); - } else { - menuRefPtr = Tcl_GetHashValue(hashEntryPtr); - } - return menuRefPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkFindMenuReferences -- - * - * Given a pathname, gives back a pointer to the TkMenuReferences - * structure. - * - * Results: - * Returns a pointer to a menu reference structure. Should not be freed - * by calller; when a field of the reference is cleared, - * TkFreeMenuReferences should be called. Returns NULL if no reference - * with this pathname exists. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TkMenuReferences * -TkFindMenuReferences( - Tcl_Interp *interp, /* The interp the menu is living in. */ - const char *pathName) /* The path of the menu widget. */ -{ - Tcl_HashEntry *hashEntryPtr; - TkMenuReferences *menuRefPtr = NULL; - Tcl_HashTable *menuTablePtr; - - menuTablePtr = TkGetMenuHashTable(interp); - hashEntryPtr = Tcl_FindHashEntry(menuTablePtr, pathName); - if (hashEntryPtr != NULL) { - menuRefPtr = Tcl_GetHashValue(hashEntryPtr); - } - return menuRefPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TkFindMenuReferencesObj -- - * - * Given a pathname, gives back a pointer to the TkMenuReferences - * structure. - * - * Results: - * Returns a pointer to a menu reference structure. Should not be freed - * by calller; when a field of the reference is cleared, - * TkFreeMenuReferences should be called. Returns NULL if no reference - * with this pathname exists. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TkMenuReferences * -TkFindMenuReferencesObj( - Tcl_Interp *interp, /* The interp the menu is living in. */ - Tcl_Obj *objPtr) /* The path of the menu widget. */ -{ - const char *pathName = Tcl_GetString(objPtr); - - return TkFindMenuReferences(interp, pathName); -} - -/* - *---------------------------------------------------------------------- - * - * TkFreeMenuReferences -- - * - * This is called after one of the fields in a menu reference is cleared. - * It cleans up the ref if it is now empty. - * - * Results: - * Returns 1 if the references structure was freed, and 0 otherwise. - * - * Side effects: - * If this is the last field to be cleared, the menu ref is taken out of - * the hash table. - * - *---------------------------------------------------------------------- - */ - -int -TkFreeMenuReferences( - TkMenuReferences *menuRefPtr) - /* The menu reference to free. */ -{ - if ((menuRefPtr->menuPtr == NULL) - && (menuRefPtr->parentEntryPtr == NULL) - && (menuRefPtr->topLevelListPtr == NULL)) { - Tcl_DeleteHashEntry(menuRefPtr->hashEntryPtr); - ckfree(menuRefPtr); - return 1; - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteMenuCloneEntries -- - * - * For every clone in this clone chain, delete the menu entries given by - * the parameters. - * - * Results: - * None. - * - * Side effects: - * The appropriate entries are deleted from all clones of this menu. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteMenuCloneEntries( - TkMenu *menuPtr, /* The menu the command was issued with. */ - int first, /* The zero-based first entry in the set of - * entries to delete. */ - int last) /* The zero-based last entry. */ -{ - TkMenu *menuListPtr; - int numDeleted, i, j; - - numDeleted = last + 1 - first; - for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL; - menuListPtr = menuListPtr->nextInstancePtr) { - for (i = last; i >= first; i--) { - Tcl_EventuallyFree(menuListPtr->entries[i], (Tcl_FreeProc *) DestroyMenuEntry); - } - for (i = last + 1; i < menuListPtr->numEntries; i++) { - j = i - numDeleted; - menuListPtr->entries[j] = menuListPtr->entries[i]; - menuListPtr->entries[j]->index = j; - } - menuListPtr->numEntries -= numDeleted; - if (menuListPtr->numEntries == 0) { - ckfree(menuListPtr->entries); - menuListPtr->entries = NULL; - } - if ((menuListPtr->active >= first) - && (menuListPtr->active <= last)) { - menuListPtr->active = -1; - } else if (menuListPtr->active > last) { - menuListPtr->active -= numDeleted; - } - TkEventuallyRecomputeMenu(menuListPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TkMenuCleanup -- - * - * Resets menusInitialized to allow Tk to be finalized and reused without - * the DLL being unloaded. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -TkMenuCleanup( - ClientData unused) -{ - menusInitialized = 0; -} - -/* - *---------------------------------------------------------------------- - * - * TkMenuInit -- - * - * Sets up the hash tables and the variables used by the menu package. - * - * Results: - * None. - * - * Side effects: - * lastMenuID gets initialized, and the parent hash and the command hash - * are allocated. - * - *---------------------------------------------------------------------- - */ - -void -TkMenuInit(void) -{ - ThreadSpecificData *tsdPtr = - Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); - - if (!menusInitialized) { - Tcl_MutexLock(&menuMutex); - if (!menusInitialized) { - TkpMenuInit(); - menusInitialized = 1; - } - - /* - * Make sure we cleanup on finalize. - */ - - TkCreateExitHandler((Tcl_ExitProc *) TkMenuCleanup, NULL); - Tcl_MutexUnlock(&menuMutex); - } - if (!tsdPtr->menusInitialized) { - TkpMenuThreadInit(); - tsdPtr->menuOptionTable = - Tk_CreateOptionTable(NULL, tkMenuConfigSpecs); - tsdPtr->entryOptionTables[TEAROFF_ENTRY] = - Tk_CreateOptionTable(NULL, specsArray[TEAROFF_ENTRY]); - tsdPtr->entryOptionTables[COMMAND_ENTRY] = - Tk_CreateOptionTable(NULL, specsArray[COMMAND_ENTRY]); - tsdPtr->entryOptionTables[CASCADE_ENTRY] = - Tk_CreateOptionTable(NULL, specsArray[CASCADE_ENTRY]); - tsdPtr->entryOptionTables[SEPARATOR_ENTRY] = - Tk_CreateOptionTable(NULL, specsArray[SEPARATOR_ENTRY]); - tsdPtr->entryOptionTables[RADIO_BUTTON_ENTRY] = - Tk_CreateOptionTable(NULL, specsArray[RADIO_BUTTON_ENTRY]); - tsdPtr->entryOptionTables[CHECK_BUTTON_ENTRY] = - Tk_CreateOptionTable(NULL, specsArray[CHECK_BUTTON_ENTRY]); - tsdPtr->menusInitialized = 1; - } -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |