3216 lines
97 KiB
C
3216 lines
97 KiB
C
/*
|
||
* 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-1997 Sun Microsystems, Inc.
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution
|
||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*
|
||
* SCCS: @(#) tkMenu.c 1.148 97/10/29 09:22:00
|
||
*/
|
||
|
||
/*
|
||
* 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.
|
||
*
|
||
*/
|
||
|
||
#include "tkPort.h"
|
||
#include "tkMenu.h"
|
||
|
||
#ifdef BGLK_CODE
|
||
# define STk_tcl_setvar SCM_tcl_setvar
|
||
# define STk_tcl_getvar SCM_tcl_getvar
|
||
# define STk_NewSymbolObj SCM_NewSymbolObj
|
||
#endif
|
||
|
||
#define MENU_HASH_KEY "tkMenus"
|
||
|
||
static int menusInitialized; /* Whether or not the hash tables, etc., have
|
||
* been setup */
|
||
|
||
/*
|
||
* Configuration specs for individual menu entries. If this changes, be sure
|
||
* to update code in TkpMenuInit that changes the font string entry.
|
||
*/
|
||
|
||
Tk_ConfigSpec tkMenuEntryConfigSpecs[] = {
|
||
{TK_CONFIG_BORDER, "-activebackground", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_ACTIVE_BG, Tk_Offset(TkMenuEntry, activeBorder),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_COLOR, "-activeforeground", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_ACTIVE_FG, Tk_Offset(TkMenuEntry, activeFg),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_STRING, "-accelerator", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_ACCELERATOR, Tk_Offset(TkMenuEntry, accel),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_BORDER, "-background", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_BG, Tk_Offset(TkMenuEntry, border),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|SEPARATOR_MASK|TEAROFF_MASK|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_BITMAP, "-bitmap", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_BITMAP, Tk_Offset(TkMenuEntry, bitmap),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_BOOLEAN, "-columnbreak", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_COLUMN_BREAK, Tk_Offset(TkMenuEntry, columnBreak),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK},
|
||
#ifdef SCM_CODE
|
||
{TK_CONFIG_CLOSURE, "-command", (char *) NULL, (char *) NULL,
|
||
#else
|
||
{TK_CONFIG_STRING, "-command", (char *) NULL, (char *) NULL,
|
||
#endif
|
||
DEF_MENU_ENTRY_COMMAND, Tk_Offset(TkMenuEntry, command),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
#ifdef STk_CODE
|
||
{TK_CONFIG_ENV, "-environment", "environment", "Environment",
|
||
DEF_MENU_ENTRY_ENV, Tk_Offset(TkMenuEntry, env),
|
||
CHECK_BUTTON_MASK|RADIO_BUTTON_MASK},
|
||
#endif
|
||
{TK_CONFIG_FONT, "-font", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_FONT, Tk_Offset(TkMenuEntry, tkfont),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_COLOR, "-foreground", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_FG, Tk_Offset(TkMenuEntry, fg),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_BOOLEAN, "-hidemargin", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_HIDE_MARGIN, Tk_Offset(TkMenuEntry, hideMargin),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|SEPARATOR_MASK|TEAROFF_MASK},
|
||
#ifdef BGLK_CODE
|
||
{TK_CONFIG_INT, "-highlightthickness", "highlightthickness", "Highlightthickness",
|
||
0, Tk_Offset(TkMenuEntry, highlightthickness),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK},
|
||
#endif
|
||
#ifdef SCM_CODE
|
||
{TK_CONFIG_IMAGE, "-image", (char *) NULL, (char *) NULL,
|
||
#else
|
||
{TK_CONFIG_STRING, "-image", (char *) NULL, (char *) NULL,
|
||
#endif
|
||
DEF_MENU_ENTRY_IMAGE, Tk_Offset(TkMenuEntry, imageString),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_BOOLEAN, "-indicatoron", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_INDICATOR, Tk_Offset(TkMenuEntry, indicatorOn),
|
||
CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_DONT_SET_DEFAULT},
|
||
{TK_CONFIG_STRING, "-label", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_LABEL, Tk_Offset(TkMenuEntry, label),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK},
|
||
#ifdef SCM_CODE
|
||
{TK_CONFIG_MENU, "-menu", (char *) NULL, (char *) NULL,
|
||
#else
|
||
{TK_CONFIG_STRING, "-menu", (char *) NULL, (char *) NULL,
|
||
#endif
|
||
DEF_MENU_ENTRY_MENU, Tk_Offset(TkMenuEntry, name),
|
||
CASCADE_MASK|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_STRING, "-offvalue", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_OFF_VALUE, Tk_Offset(TkMenuEntry, offValue),
|
||
CHECK_BUTTON_MASK},
|
||
{TK_CONFIG_STRING, "-onvalue", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_ON_VALUE, Tk_Offset(TkMenuEntry, onValue),
|
||
CHECK_BUTTON_MASK},
|
||
{TK_CONFIG_COLOR, "-selectcolor", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_SELECT, Tk_Offset(TkMenuEntry, indicatorFg),
|
||
CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_STRING, "-selectimage", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_SELECT_IMAGE, Tk_Offset(TkMenuEntry, selectImageString),
|
||
CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_UID, "-state", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_STATE, Tk_Offset(TkMenuEntry, state),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TEAROFF_MASK|TK_CONFIG_DONT_SET_DEFAULT},
|
||
{TK_CONFIG_STRING, "-value", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_VALUE, Tk_Offset(TkMenuEntry, onValue),
|
||
RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_STRING, "-variable", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_CHECK_VARIABLE, Tk_Offset(TkMenuEntry, name),
|
||
CHECK_BUTTON_MASK|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_STRING, "-variable", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_RADIO_VARIABLE, Tk_Offset(TkMenuEntry, name),
|
||
RADIO_BUTTON_MASK},
|
||
{TK_CONFIG_INT, "-underline", (char *) NULL, (char *) NULL,
|
||
DEF_MENU_ENTRY_UNDERLINE, Tk_Offset(TkMenuEntry, underline),
|
||
COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK
|
||
|TK_CONFIG_DONT_SET_DEFAULT},
|
||
{TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
|
||
(char *) NULL, 0, 0}
|
||
};
|
||
|
||
/*
|
||
* Configuration specs valid for the menu as a whole. If this changes, be sure
|
||
* to update code in TkpMenuInit that changes the font string entry.
|
||
*/
|
||
|
||
Tk_ConfigSpec tkMenuConfigSpecs[] = {
|
||
{TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground",
|
||
DEF_MENU_ACTIVE_BG_COLOR, Tk_Offset(TkMenu, activeBorder),
|
||
TK_CONFIG_COLOR_ONLY},
|
||
{TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground",
|
||
DEF_MENU_ACTIVE_BG_MONO, Tk_Offset(TkMenu, activeBorder),
|
||
TK_CONFIG_MONO_ONLY},
|
||
{TK_CONFIG_PIXELS, "-activeborderwidth", "activeBorderWidth",
|
||
"BorderWidth", DEF_MENU_ACTIVE_BORDER_WIDTH,
|
||
Tk_Offset(TkMenu, activeBorderWidth), 0},
|
||
{TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background",
|
||
DEF_MENU_ACTIVE_FG_COLOR, Tk_Offset(TkMenu, activeFg),
|
||
TK_CONFIG_COLOR_ONLY},
|
||
{TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background",
|
||
DEF_MENU_ACTIVE_FG_MONO, Tk_Offset(TkMenu, activeFg),
|
||
TK_CONFIG_MONO_ONLY},
|
||
{TK_CONFIG_BORDER, "-background", "background", "Background",
|
||
DEF_MENU_BG_COLOR, Tk_Offset(TkMenu, border), TK_CONFIG_COLOR_ONLY},
|
||
{TK_CONFIG_BORDER, "-background", "background", "Background",
|
||
DEF_MENU_BG_MONO, Tk_Offset(TkMenu, border), TK_CONFIG_MONO_ONLY},
|
||
{TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL,
|
||
(char *) NULL, 0, 0},
|
||
{TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL,
|
||
(char *) NULL, 0, 0},
|
||
{TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth",
|
||
DEF_MENU_BORDER_WIDTH, Tk_Offset(TkMenu, borderWidth), 0},
|
||
{TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor",
|
||
DEF_MENU_CURSOR, Tk_Offset(TkMenu, cursor), TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground",
|
||
"DisabledForeground", DEF_MENU_DISABLED_FG_COLOR,
|
||
Tk_Offset(TkMenu, disabledFg), TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground",
|
||
"DisabledForeground", DEF_MENU_DISABLED_FG_MONO,
|
||
Tk_Offset(TkMenu, disabledFg), TK_CONFIG_MONO_ONLY|TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL,
|
||
(char *) NULL, 0, 0},
|
||
{TK_CONFIG_FONT, "-font", "font", "Font",
|
||
DEF_MENU_FONT, Tk_Offset(TkMenu, tkfont), 0},
|
||
{TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground",
|
||
DEF_MENU_FG, Tk_Offset(TkMenu, fg), 0},
|
||
#ifdef SCM_CODE
|
||
{TK_CONFIG_CLOSURE, "-postcommand", "postCommand", "Command",
|
||
#else
|
||
{TK_CONFIG_STRING, "-postcommand", "postCommand", "Command",
|
||
#endif
|
||
DEF_MENU_POST_COMMAND, Tk_Offset(TkMenu, postCommand),
|
||
TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_RELIEF, "-relief", "relief", "Relief",
|
||
DEF_MENU_RELIEF, Tk_Offset(TkMenu, relief), 0},
|
||
{TK_CONFIG_COLOR, "-selectcolor", "selectColor", "Background",
|
||
DEF_MENU_SELECT_COLOR, Tk_Offset(TkMenu, indicatorFg),
|
||
TK_CONFIG_COLOR_ONLY},
|
||
{TK_CONFIG_COLOR, "-selectcolor", "selectColor", "Background",
|
||
DEF_MENU_SELECT_MONO, Tk_Offset(TkMenu, indicatorFg),
|
||
TK_CONFIG_MONO_ONLY},
|
||
#ifdef SCM_CODE
|
||
{TK_CONFIG_CLOSURE, "-takefocus", "takeFocus", "TakeFocus",
|
||
#else
|
||
{TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus",
|
||
#endif
|
||
DEF_MENU_TAKE_FOCUS, Tk_Offset(TkMenu, takeFocus), TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_BOOLEAN, "-tearoff", "tearOff", "TearOff",
|
||
DEF_MENU_TEAROFF, Tk_Offset(TkMenu, tearOff), 0},
|
||
#ifdef SCM_CODE
|
||
{TK_CONFIG_CLOSURE, "-tearoffcommand", "tearOffCommand", "TearOffCommand",
|
||
#else
|
||
{TK_CONFIG_STRING, "-tearoffcommand", "tearOffCommand", "TearOffCommand",
|
||
#endif
|
||
DEF_MENU_TEAROFF_CMD, Tk_Offset(TkMenu, tearOffCommand),
|
||
TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_STRING, "-title", "title", "Title",
|
||
DEF_MENU_TITLE, Tk_Offset(TkMenu, title), TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_STRING, "-type", "type", "Type",
|
||
DEF_MENU_TYPE, Tk_Offset(TkMenu, menuTypeName), TK_CONFIG_NULL_OK},
|
||
{TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
|
||
(char *) NULL, 0, 0}
|
||
};
|
||
|
||
/*
|
||
* Prototypes for static procedures in this file:
|
||
*/
|
||
|
||
static int CloneMenu _ANSI_ARGS_((TkMenu *menuPtr,
|
||
char *newMenuName, char *newMenuTypeString));
|
||
static int ConfigureMenu _ANSI_ARGS_((Tcl_Interp *interp,
|
||
TkMenu *menuPtr, int argc, char **argv,
|
||
int flags));
|
||
static int ConfigureMenuCloneEntries _ANSI_ARGS_((
|
||
Tcl_Interp *interp, TkMenu *menuPtr, int index,
|
||
int argc, char **argv, int flags));
|
||
static int ConfigureMenuEntry _ANSI_ARGS_((TkMenuEntry *mePtr,
|
||
int argc, char **argv, int flags));
|
||
static void DeleteMenuCloneEntries _ANSI_ARGS_((TkMenu *menuPtr,
|
||
int first, int last));
|
||
static void DestroyMenuHashTable _ANSI_ARGS_((
|
||
ClientData clientData, Tcl_Interp *interp));
|
||
static void DestroyMenuInstance _ANSI_ARGS_((TkMenu *menuPtr));
|
||
static void DestroyMenuEntry _ANSI_ARGS_((char *memPtr));
|
||
static int GetIndexFromCoords
|
||
_ANSI_ARGS_((Tcl_Interp *interp, TkMenu *menuPtr,
|
||
char *string, int *indexPtr));
|
||
static int MenuDoYPosition _ANSI_ARGS_((Tcl_Interp *interp,
|
||
TkMenu *menuPtr, char *arg));
|
||
static int MenuAddOrInsert _ANSI_ARGS_((Tcl_Interp *interp,
|
||
TkMenu *menuPtr, char *indexString, int argc,
|
||
char **argv));
|
||
static void MenuCmdDeletedProc _ANSI_ARGS_((
|
||
ClientData clientData));
|
||
static TkMenuEntry * MenuNewEntry _ANSI_ARGS_((TkMenu *menuPtr, int index,
|
||
int type));
|
||
static char * MenuVarProc _ANSI_ARGS_((ClientData clientData,
|
||
Tcl_Interp *interp, char *name1, char *name2,
|
||
int flags));
|
||
static int MenuWidgetCmd _ANSI_ARGS_((ClientData clientData,
|
||
Tcl_Interp *interp, int argc, char **argv));
|
||
static void MenuWorldChanged _ANSI_ARGS_((
|
||
ClientData instanceData));
|
||
static void RecursivelyDeleteMenu _ANSI_ARGS_((TkMenu *menuPtr));
|
||
static void UnhookCascadeEntry _ANSI_ARGS_((TkMenuEntry *mePtr));
|
||
|
||
/*
|
||
* 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 TkClassProcs menuClass = {
|
||
NULL, /* createProc. */
|
||
MenuWorldChanged /* geometryProc. */
|
||
};
|
||
|
||
|
||
|
||
/*
|
||
*--------------------------------------------------------------
|
||
*
|
||
* Tk_MenuCmd --
|
||
*
|
||
* This procedure 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_MenuCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Main window associated with
|
||
* interpreter. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
Tk_Window tkwin = (Tk_Window) clientData;
|
||
Tk_Window new;
|
||
register TkMenu *menuPtr;
|
||
TkMenuReferences *menuRefPtr;
|
||
int i, len;
|
||
char *arg, c;
|
||
int toplevel;
|
||
|
||
if (argc < 2) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " pathName ?options?\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
TkMenuInit();
|
||
|
||
toplevel = 1;
|
||
for (i = 2; i < argc; i += 2) {
|
||
arg = argv[i];
|
||
len = strlen(arg);
|
||
if (len < 2) {
|
||
continue;
|
||
}
|
||
c = arg[1];
|
||
if ((c == 't') && (strncmp(arg, "-type", strlen(arg)) == 0)
|
||
&& (len >= 3)) {
|
||
if (strcmp(argv[i + 1], "menubar") == 0) {
|
||
toplevel = 0;
|
||
}
|
||
break;
|
||
}
|
||
}
|
||
|
||
new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], toplevel ? ""
|
||
: NULL);
|
||
if (new == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Initialize the data structure for the menu.
|
||
*/
|
||
|
||
menuPtr = (TkMenu *) ckalloc(sizeof(TkMenu));
|
||
menuPtr->tkwin = new;
|
||
menuPtr->display = Tk_Display(new);
|
||
menuPtr->interp = interp;
|
||
menuPtr->widgetCmd = Tcl_CreateCommand(interp,
|
||
Tk_PathName(menuPtr->tkwin), MenuWidgetCmd,
|
||
(ClientData) menuPtr, MenuCmdDeletedProc);
|
||
menuPtr->entries = NULL;
|
||
menuPtr->numEntries = 0;
|
||
menuPtr->active = -1;
|
||
menuPtr->border = NULL;
|
||
menuPtr->borderWidth = 0;
|
||
menuPtr->relief = TK_RELIEF_FLAT;
|
||
menuPtr->activeBorder = NULL;
|
||
menuPtr->activeBorderWidth = 0;
|
||
menuPtr->tkfont = NULL;
|
||
menuPtr->fg = NULL;
|
||
menuPtr->disabledFg = NULL;
|
||
menuPtr->activeFg = NULL;
|
||
menuPtr->indicatorFg = NULL;
|
||
menuPtr->tearOff = 1;
|
||
menuPtr->tearOffCommand = NULL;
|
||
menuPtr->cursor = None;
|
||
menuPtr->takeFocus = NULL;
|
||
menuPtr->postCommand = NULL;
|
||
menuPtr->postCommandGeneration = 0;
|
||
menuPtr->postedCascade = NULL;
|
||
menuPtr->nextInstancePtr = NULL;
|
||
menuPtr->masterMenuPtr = menuPtr;
|
||
menuPtr->menuType = UNKNOWN_TYPE;
|
||
menuPtr->menuFlags = 0;
|
||
menuPtr->parentTopLevelPtr = NULL;
|
||
menuPtr->menuTypeName = NULL;
|
||
menuPtr->title = NULL;
|
||
|
||
TkMenuInitializeDrawingFields(menuPtr);
|
||
menuRefPtr = TkCreateMenuReferences(menuPtr->interp,
|
||
Tk_PathName(menuPtr->tkwin));
|
||
menuRefPtr->menuPtr = menuPtr;
|
||
menuPtr->menuRefPtr = menuRefPtr;
|
||
if (TCL_OK != TkpNewMenu(menuPtr)) {
|
||
goto error;
|
||
}
|
||
|
||
Tk_SetClass(menuPtr->tkwin, "Menu");
|
||
TkSetClassProcs(menuPtr->tkwin, &menuClass, (ClientData) menuPtr);
|
||
Tk_CreateEventHandler(new, ExposureMask|StructureNotifyMask|ActivateMask,
|
||
TkMenuEventProc, (ClientData) menuPtr);
|
||
if (ConfigureMenu(interp, menuPtr, argc-2, argv+2, 0) != TCL_OK) {
|
||
goto 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;
|
||
char *newMenuName;
|
||
char *newArgv[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)))) {
|
||
newArgv[0] = "-menu";
|
||
newArgv[1] = Tk_PathName(menuPtr->tkwin);
|
||
ConfigureMenuEntry(cascadeListPtr, 2, newArgv,
|
||
TK_CONFIG_ARGV_ONLY);
|
||
} else {
|
||
newMenuName = TkNewMenuName(menuPtr->interp,
|
||
Tk_PathName(cascadeListPtr->menuPtr->tkwin),
|
||
menuPtr);
|
||
CloneMenu(menuPtr, newMenuName, "normal");
|
||
|
||
/*
|
||
* Now we can set the new menu instance to be the cascade entry
|
||
* of the parent's instance.
|
||
*/
|
||
|
||
newArgv[0] = "-menu";
|
||
newArgv[1] = newMenuName;
|
||
ConfigureMenuEntry(cascadeListPtr, 2, newArgv,
|
||
TK_CONFIG_ARGV_ONLY);
|
||
if (newMenuName != NULL) {
|
||
ckfree(newMenuName);
|
||
}
|
||
}
|
||
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;
|
||
}
|
||
}
|
||
|
||
#ifdef STk_CODE
|
||
STk_sharp_dot_result(interp, Tk_PathName(menuPtr->tkwin));
|
||
#else
|
||
interp->result = Tk_PathName(menuPtr->tkwin);
|
||
#endif
|
||
return TCL_OK;
|
||
|
||
error:
|
||
Tk_DestroyWindow(menuPtr->tkwin);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*--------------------------------------------------------------
|
||
*
|
||
* MenuWidgetCmd --
|
||
*
|
||
* This procedure 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
|
||
MenuWidgetCmd(clientData, interp, argc, argv)
|
||
ClientData clientData; /* Information about menu widget. */
|
||
Tcl_Interp *interp; /* Current interpreter. */
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Argument strings. */
|
||
{
|
||
register TkMenu *menuPtr = (TkMenu *) clientData;
|
||
register TkMenuEntry *mePtr;
|
||
int result = TCL_OK;
|
||
size_t length;
|
||
int c;
|
||
|
||
if (argc < 2) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " option ?arg arg ...?\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_Preserve((ClientData) menuPtr);
|
||
c = argv[1][0];
|
||
length = strlen(argv[1]);
|
||
if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)
|
||
&& (length >= 2)) {
|
||
int index;
|
||
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " activate index\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if (menuPtr->active == index) {
|
||
goto done;
|
||
}
|
||
if (index >= 0) {
|
||
if ((menuPtr->entries[index]->type == SEPARATOR_ENTRY)
|
||
|| (menuPtr->entries[index]->state == tkDisabledUid)) {
|
||
index = -1;
|
||
}
|
||
}
|
||
result = TkActivateMenuEntry(menuPtr, index);
|
||
} else if ((c == 'a') && (strncmp(argv[1], "add", length) == 0)
|
||
&& (length >= 2)) {
|
||
if (argc < 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " add type ?options?\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (MenuAddOrInsert(interp, menuPtr, (char *) NULL,
|
||
argc-2, argv+2) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
} else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0)
|
||
&& (length >= 2)) {
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " cget option\"",
|
||
(char *) NULL);
|
||
goto error;
|
||
}
|
||
result = Tk_ConfigureValue(interp, menuPtr->tkwin, tkMenuConfigSpecs,
|
||
(char *) menuPtr, argv[2], 0);
|
||
} else if ((c == 'c') && (strncmp(argv[1], "clone", length) == 0)
|
||
&& (length >=2)) {
|
||
if ((argc < 3) || (argc > 4)) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " clone newMenuName ?menuType?\"",
|
||
(char *) NULL);
|
||
goto error;
|
||
}
|
||
result = CloneMenu(menuPtr, argv[2], (argc == 3) ? NULL : argv[3]);
|
||
} else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)
|
||
&& (length >= 2)) {
|
||
if (argc == 2) {
|
||
result = Tk_ConfigureInfo(interp, menuPtr->tkwin,
|
||
tkMenuConfigSpecs, (char *) menuPtr, (char *) NULL, 0);
|
||
} else if (argc == 3) {
|
||
result = Tk_ConfigureInfo(interp, menuPtr->tkwin,
|
||
tkMenuConfigSpecs, (char *) menuPtr, argv[2], 0);
|
||
} else {
|
||
result = ConfigureMenu(interp, menuPtr, argc-2, argv+2,
|
||
TK_CONFIG_ARGV_ONLY);
|
||
}
|
||
} else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) {
|
||
int first, last;
|
||
|
||
if ((argc != 3) && (argc != 4)) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " delete first ?last?\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &first) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if (argc == 3) {
|
||
last = first;
|
||
} else {
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[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);
|
||
} else if ((c == 'e') && (length >= 7)
|
||
&& (strncmp(argv[1], "entrycget", length) == 0)) {
|
||
int index;
|
||
|
||
if (argc != 4) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " entrycget index option\"",
|
||
(char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if (index < 0) {
|
||
goto done;
|
||
}
|
||
mePtr = menuPtr->entries[index];
|
||
Tcl_Preserve((ClientData) mePtr);
|
||
result = Tk_ConfigureValue(interp, menuPtr->tkwin,
|
||
tkMenuEntryConfigSpecs, (char *) mePtr, argv[3],
|
||
COMMAND_MASK << mePtr->type);
|
||
Tcl_Release((ClientData) mePtr);
|
||
} else if ((c == 'e') && (length >= 7)
|
||
&& (strncmp(argv[1], "entryconfigure", length) == 0)) {
|
||
int index;
|
||
|
||
if (argc < 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " entryconfigure index ?option value ...?\"",
|
||
(char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if (index < 0) {
|
||
goto done;
|
||
}
|
||
mePtr = menuPtr->entries[index];
|
||
Tcl_Preserve((ClientData) mePtr);
|
||
if (argc == 3) {
|
||
result = Tk_ConfigureInfo(interp, menuPtr->tkwin,
|
||
tkMenuEntryConfigSpecs, (char *) mePtr, (char *) NULL,
|
||
COMMAND_MASK << mePtr->type);
|
||
} else if (argc == 4) {
|
||
result = Tk_ConfigureInfo(interp, menuPtr->tkwin,
|
||
tkMenuEntryConfigSpecs, (char *) mePtr, argv[3],
|
||
COMMAND_MASK << mePtr->type);
|
||
} else {
|
||
result = ConfigureMenuCloneEntries(interp, menuPtr, index,
|
||
argc-3, argv+3,
|
||
TK_CONFIG_ARGV_ONLY | COMMAND_MASK << mePtr->type);
|
||
}
|
||
Tcl_Release((ClientData) mePtr);
|
||
} else if ((c == 'h')
|
||
&& (strncmp(argv[1], "highlightthickness", length) == 0)) {
|
||
if (argc == 2)
|
||
interp->result = "0";
|
||
} else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)
|
||
&& (length >= 3)) {
|
||
int index;
|
||
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " index string\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if (index < 0) {
|
||
#ifdef SCM_CODE
|
||
interp->result = "\"none\"";
|
||
#else
|
||
interp->result = "none";
|
||
#endif
|
||
} else {
|
||
sprintf(interp->result, "%d", index);
|
||
}
|
||
} else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0)
|
||
&& (length >= 3)) {
|
||
if (argc < 4) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " insert index type ?options?\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (MenuAddOrInsert(interp, menuPtr, argv[2],
|
||
argc-3, argv+3) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
} else if ((c == 'i') && (strncmp(argv[1], "invoke", length) == 0)
|
||
&& (length >= 3)) {
|
||
int index;
|
||
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " invoke index\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if (index < 0) {
|
||
goto done;
|
||
}
|
||
result = TkInvokeMenu(interp, menuPtr, index);
|
||
} else if ((c == 'p') && (strncmp(argv[1], "post", length) == 0)
|
||
&& (length == 4)) {
|
||
int x, y;
|
||
|
||
if (argc != 4) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " post x y\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK)
|
||
|| (Tcl_GetInt(interp, argv[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.
|
||
*/
|
||
|
||
if (menuPtr->menuType != TEAROFF_MENU) {
|
||
result = TkpPostMenu(interp, menuPtr, x, y);
|
||
} else {
|
||
result = TkPostTearoffMenu(interp, menuPtr, x, y);
|
||
}
|
||
} else if ((c == 'p') && (strncmp(argv[1], "postcascade", length) == 0)
|
||
&& (length > 4)) {
|
||
int index;
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " postcascade index\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if ((index < 0) || (menuPtr->entries[index]->type != CASCADE_ENTRY)) {
|
||
result = TkPostSubmenu(interp, menuPtr, (TkMenuEntry *) NULL);
|
||
} else {
|
||
result = TkPostSubmenu(interp, menuPtr, menuPtr->entries[index]);
|
||
}
|
||
} else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)) {
|
||
int index;
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " type index\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) {
|
||
goto error;
|
||
}
|
||
if (index < 0) {
|
||
goto done;
|
||
}
|
||
mePtr = menuPtr->entries[index];
|
||
switch (mePtr->type) {
|
||
#ifdef SCM_CODE
|
||
case COMMAND_ENTRY:
|
||
interp->result = "\"command\"";
|
||
break;
|
||
case SEPARATOR_ENTRY:
|
||
interp->result = "\"separator\"";
|
||
break;
|
||
case CHECK_BUTTON_ENTRY:
|
||
interp->result = "\"checkbutton\"";
|
||
break;
|
||
case RADIO_BUTTON_ENTRY:
|
||
interp->result = "\"radiobutton\"";
|
||
break;
|
||
case CASCADE_ENTRY:
|
||
interp->result = "\"cascade\"";
|
||
break;
|
||
case TEAROFF_ENTRY:
|
||
interp->result = "\"tearoff\"";
|
||
break;
|
||
#else
|
||
case COMMAND_ENTRY:
|
||
interp->result = "command";
|
||
break;
|
||
case SEPARATOR_ENTRY:
|
||
interp->result = "separator";
|
||
break;
|
||
case CHECK_BUTTON_ENTRY:
|
||
interp->result = "checkbutton";
|
||
break;
|
||
case RADIO_BUTTON_ENTRY:
|
||
interp->result = "radiobutton";
|
||
break;
|
||
case CASCADE_ENTRY:
|
||
interp->result = "cascade";
|
||
break;
|
||
case TEAROFF_ENTRY:
|
||
interp->result = "tearoff";
|
||
break;
|
||
#endif
|
||
}
|
||
} else if ((c == 'u') && (strncmp(argv[1], "unpost", length) == 0)) {
|
||
if (argc != 2) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " unpost\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
Tk_UnmapWindow(menuPtr->tkwin);
|
||
result = TkPostSubmenu(interp, menuPtr, (TkMenuEntry *) NULL);
|
||
} else if ((c == 'y') && (strncmp(argv[1], "yposition", length) == 0)) {
|
||
if (argc != 3) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
||
argv[0], " yposition index\"", (char *) NULL);
|
||
goto error;
|
||
}
|
||
result = MenuDoYPosition(interp, menuPtr, argv[2]);
|
||
} else {
|
||
Tcl_AppendResult(interp, "bad option \"", argv[1],
|
||
"\": must be activate, add, cget, clone, configure, delete, ",
|
||
"entrycget, entryconfigure, index, insert, invoke, ",
|
||
"post, postcascade, type, unpost, or yposition",
|
||
(char *) NULL);
|
||
goto error;
|
||
}
|
||
done:
|
||
Tcl_Release((ClientData) menuPtr);
|
||
return result;
|
||
|
||
error:
|
||
Tcl_Release((ClientData) 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(interp, menuPtr, index)
|
||
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 == tkDisabledUid) {
|
||
goto done;
|
||
}
|
||
Tcl_Preserve((ClientData) mePtr);
|
||
if (mePtr->type == TEAROFF_ENTRY) {
|
||
Tcl_DString commandDString;
|
||
|
||
Tcl_DStringInit(&commandDString);
|
||
#ifdef STk_CODE
|
||
Tcl_DStringAppendElement(&commandDString, "Tk:tear-off-menu");
|
||
#else
|
||
Tcl_DStringAppendElement(&commandDString, "tkTearOffMenu");
|
||
#endif
|
||
Tcl_DStringAppendElement(&commandDString, Tk_PathName(menuPtr->tkwin));
|
||
result = Tcl_Eval(interp, Tcl_DStringValue(&commandDString));
|
||
Tcl_DStringFree(&commandDString);
|
||
} else if (mePtr->type == CHECK_BUTTON_ENTRY) {
|
||
if (mePtr->entryFlags & ENTRY_SELECTED) {
|
||
#ifdef SCM_CODE
|
||
if (STk_tcl_setvar(mePtr->name, mePtr->offValue, 0,
|
||
mePtr->env) == NULL) {
|
||
#else
|
||
if (Tcl_SetVar(interp, mePtr->name, mePtr->offValue,
|
||
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
|
||
#endif
|
||
result = TCL_ERROR;
|
||
}
|
||
} else {
|
||
#ifdef SCM_CODE
|
||
if (STk_tcl_setvar(mePtr->name, mePtr->onValue, 0,
|
||
mePtr->env) == NULL) {
|
||
#else
|
||
if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue,
|
||
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
|
||
#endif
|
||
result = TCL_ERROR;
|
||
}
|
||
}
|
||
} else if (mePtr->type == RADIO_BUTTON_ENTRY) {
|
||
#ifdef SCM_CODE
|
||
if (STk_tcl_setvar(mePtr->name, mePtr->onValue, 0,
|
||
mePtr->env) == NULL) {
|
||
#else
|
||
if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue,
|
||
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
|
||
#endif
|
||
result = TCL_ERROR;
|
||
}
|
||
}
|
||
if ((result == TCL_OK) && (mePtr->command != NULL)) {
|
||
result = TkCopyAndGlobalEval(interp, mePtr->command);
|
||
}
|
||
Tcl_Release((ClientData) mePtr);
|
||
done:
|
||
return result;
|
||
}
|
||
|
||
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* DestroyMenuInstance --
|
||
*
|
||
* This procedure 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(menuPtr)
|
||
TkMenu *menuPtr; /* Info about menu widget. */
|
||
{
|
||
int i, numEntries = menuPtr->numEntries;
|
||
TkMenu *menuInstancePtr;
|
||
TkMenuEntry *cascadePtr, *nextCascadePtr;
|
||
char *newArgv[2];
|
||
TkMenu *parentMasterMenuPtr;
|
||
TkMenuEntry *parentMasterEntryPtr;
|
||
TkMenu *parentMenuPtr;
|
||
|
||
/*
|
||
* 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);
|
||
cascadePtr = menuPtr->menuRefPtr->parentEntryPtr;
|
||
menuPtr->menuRefPtr->menuPtr = NULL;
|
||
TkFreeMenuReferences(menuPtr->menuRefPtr);
|
||
|
||
for (; cascadePtr != NULL; cascadePtr = nextCascadePtr) {
|
||
parentMenuPtr = cascadePtr->menuPtr;
|
||
nextCascadePtr = cascadePtr->nextCascadePtr;
|
||
|
||
if (menuPtr->masterMenuPtr != menuPtr) {
|
||
parentMasterMenuPtr = cascadePtr->menuPtr->masterMenuPtr;
|
||
parentMasterEntryPtr =
|
||
parentMasterMenuPtr->entries[cascadePtr->index];
|
||
newArgv[0] = "-menu";
|
||
newArgv[1] = parentMasterEntryPtr->name;
|
||
ConfigureMenuEntry(cascadePtr, 2, newArgv, TK_CONFIG_ARGV_ONLY);
|
||
} else {
|
||
ConfigureMenuEntry(cascadePtr, 0, (char **) NULL, 0);
|
||
}
|
||
}
|
||
|
||
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) {
|
||
panic("Attempting to delete master menu when there are still clones.");
|
||
}
|
||
|
||
/*
|
||
* Free up all the stuff that requires special handling, then
|
||
* let Tk_FreeOptions handle all the standard option-related
|
||
* stuff.
|
||
*/
|
||
|
||
for (i = numEntries - 1; i >= 0; i--) {
|
||
DestroyMenuEntry((char *) menuPtr->entries[i]);
|
||
}
|
||
if (menuPtr->entries != NULL) {
|
||
ckfree((char *) menuPtr->entries);
|
||
}
|
||
TkMenuFreeDrawOptions(menuPtr);
|
||
Tk_FreeOptions(tkMenuConfigSpecs, (char *) menuPtr, menuPtr->display, 0);
|
||
|
||
Tcl_EventuallyFree((ClientData) menuPtr, TCL_DYNAMIC);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TkDestroyMenu --
|
||
*
|
||
* This procedure 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(menuPtr)
|
||
TkMenu *menuPtr; /* Info about menu widget. */
|
||
{
|
||
TkMenu *menuInstancePtr;
|
||
TkMenuTopLevelList *topLevelListPtr, *nextTopLevelPtr;
|
||
|
||
if (menuPtr->menuFlags & MENU_DELETION_PENDING) {
|
||
return;
|
||
}
|
||
|
||
/*
|
||
* 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.
|
||
*/
|
||
|
||
if (menuPtr->masterMenuPtr == menuPtr) {
|
||
menuPtr->menuFlags |= MENU_DELETION_PENDING;
|
||
while (menuPtr->nextInstancePtr != NULL) {
|
||
menuInstancePtr = menuPtr->nextInstancePtr;
|
||
menuPtr->nextInstancePtr = menuInstancePtr->nextInstancePtr;
|
||
if (menuInstancePtr->tkwin != NULL) {
|
||
Tk_DestroyWindow(menuInstancePtr->tkwin);
|
||
}
|
||
}
|
||
menuPtr->menuFlags &= ~MENU_DELETION_PENDING;
|
||
}
|
||
|
||
/*
|
||
* 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;
|
||
}
|
||
DestroyMenuInstance(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.
|
||
*
|
||
* Results:
|
||
* None
|
||
*
|
||
* Side effects:
|
||
* The appropriate lists are modified.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
UnhookCascadeEntry(mePtr)
|
||
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) {
|
||
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;
|
||
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->childMenuRefPtr = NULL;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* DestroyMenuEntry --
|
||
*
|
||
* This procedure 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(memPtr)
|
||
char *memPtr; /* Pointer to entry to be freed. */
|
||
{
|
||
register TkMenuEntry *mePtr = (TkMenuEntry *) 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, (TkMenuEntry *) NULL);
|
||
}
|
||
|
||
/*
|
||
* Free up all the stuff that requires special handling, then
|
||
* let Tk_FreeOptions handle all the standard option-related
|
||
* stuff.
|
||
*/
|
||
|
||
if (mePtr->type == CASCADE_ENTRY) {
|
||
UnhookCascadeEntry(mePtr);
|
||
}
|
||
if (mePtr->image != NULL) {
|
||
Tk_FreeImage(mePtr->image);
|
||
}
|
||
if (mePtr->selectImage != NULL) {
|
||
Tk_FreeImage(mePtr->selectImage);
|
||
}
|
||
if (mePtr->name != NULL) {
|
||
Tcl_UntraceVar(menuPtr->interp, mePtr->name,
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
MenuVarProc, (ClientData) mePtr);
|
||
}
|
||
TkpDestroyMenuEntry(mePtr);
|
||
TkMenuEntryFreeDrawOptions(mePtr);
|
||
Tk_FreeOptions(tkMenuEntryConfigSpecs, (char *) mePtr, menuPtr->display,
|
||
(COMMAND_MASK << mePtr->type));
|
||
ckfree((char *) mePtr);
|
||
}
|
||
|
||
/*
|
||
*---------------------------------------------------------------------------
|
||
*
|
||
* MenuWorldChanged --
|
||
*
|
||
* This procedure 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(instanceData)
|
||
ClientData instanceData; /* Information about widget. */
|
||
{
|
||
TkMenu *menuPtr = (TkMenu *) instanceData;
|
||
int i;
|
||
|
||
TkMenuConfigureDrawOptions(menuPtr);
|
||
for (i = 0; i < menuPtr->numEntries; i++) {
|
||
TkMenuConfigureEntryDrawOptions(menuPtr->entries[i],
|
||
menuPtr->entries[i]->index);
|
||
TkpConfigureMenuEntry(menuPtr->entries[i]);
|
||
}
|
||
}
|
||
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* ConfigureMenu --
|
||
*
|
||
* This procedure 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 interp->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(interp, menuPtr, argc, argv, flags)
|
||
Tcl_Interp *interp; /* Used for error reporting. */
|
||
register TkMenu *menuPtr; /* Information about widget; may or may
|
||
* not already have values for some fields. */
|
||
int argc; /* Number of valid entries in argv. */
|
||
char **argv; /* Arguments. */
|
||
int flags; /* Flags to pass to Tk_ConfigureWidget. */
|
||
{
|
||
int i;
|
||
TkMenu* menuListPtr;
|
||
|
||
for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL;
|
||
menuListPtr = menuListPtr->nextInstancePtr) {
|
||
|
||
if (Tk_ConfigureWidget(interp, menuListPtr->tkwin,
|
||
tkMenuConfigSpecs, argc, argv, (char *) menuListPtr,
|
||
flags) != TCL_OK) {
|
||
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) {
|
||
if (strcmp(menuListPtr->menuTypeName, "menubar") == 0) {
|
||
menuListPtr->menuType = MENUBAR;
|
||
} else if (strcmp(menuListPtr->menuTypeName, "tearoff") == 0) {
|
||
menuListPtr->menuType = TEAROFF_MENU;
|
||
} else {
|
||
menuListPtr->menuType = MASTER_MENU;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* 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) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
} else if ((menuListPtr->numEntries > 0)
|
||
&& (menuListPtr->entries[0]->type == TEAROFF_ENTRY)) {
|
||
int i;
|
||
|
||
Tcl_EventuallyFree((ClientData) menuListPtr->entries[0],
|
||
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((char *) menuListPtr->entries);
|
||
menuListPtr->entries = NULL;
|
||
}
|
||
}
|
||
|
||
TkMenuConfigureDrawOptions(menuListPtr);
|
||
|
||
/*
|
||
* 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 (strcmp(menuListPtr->menuTypeName, "normal") == 0) {
|
||
TkpMakeMenuWindow(menuListPtr->tkwin, 1);
|
||
} else if (strcmp(menuListPtr->menuTypeName, "tearoff") == 0) {
|
||
TkpMakeMenuWindow(menuListPtr->tkwin, 0);
|
||
}
|
||
|
||
/*
|
||
* 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,
|
||
(char **) NULL, TK_CONFIG_ARGV_ONLY
|
||
| COMMAND_MASK << mePtr->type);
|
||
}
|
||
|
||
TkEventuallyRecomputeMenu(menuListPtr);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* ConfigureMenuEntry --
|
||
*
|
||
* This procedure 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 interp->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(mePtr, argc, argv, flags)
|
||
register TkMenuEntry *mePtr; /* Information about menu entry; may
|
||
* or may not already have values for
|
||
* some fields. */
|
||
int argc; /* Number of valid entries in argv. */
|
||
char **argv; /* Arguments. */
|
||
int flags; /* Additional flags to pass to
|
||
* Tk_ConfigureWidget. */
|
||
{
|
||
TkMenu *menuPtr = mePtr->menuPtr;
|
||
int index = mePtr->index;
|
||
Tk_Image image;
|
||
|
||
/*
|
||
* If this entry is a check button or radio button, then remove
|
||
* its old trace procedure.
|
||
*/
|
||
|
||
if ((mePtr->name != NULL)
|
||
&& ((mePtr->type == CHECK_BUTTON_ENTRY)
|
||
|| (mePtr->type == RADIO_BUTTON_ENTRY))) {
|
||
Tcl_UntraceVar(menuPtr->interp, mePtr->name,
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
MenuVarProc, (ClientData) mePtr);
|
||
}
|
||
|
||
if (menuPtr->tkwin != NULL) {
|
||
#ifdef SCM_CODE
|
||
int Tk_Menu_ConfigureWidget();
|
||
|
||
if (Tk_Menu_ConfigureWidget(menuPtr->interp, &menuPtr->entries[index],
|
||
menuPtr->tkwin,
|
||
#else
|
||
if (Tk_ConfigureWidget(menuPtr->interp, menuPtr->tkwin,
|
||
#endif
|
||
tkMenuEntryConfigSpecs, argc, argv, (char *) mePtr,
|
||
flags | (COMMAND_MASK << mePtr->type)) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* 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->label == NULL) {
|
||
mePtr->labelLength = 0;
|
||
} else {
|
||
mePtr->labelLength = strlen(mePtr->label);
|
||
}
|
||
if (mePtr->accel == NULL) {
|
||
mePtr->accelLength = 0;
|
||
} else {
|
||
mePtr->accelLength = strlen(mePtr->accel);
|
||
}
|
||
|
||
/*
|
||
* 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->name != NULL)) {
|
||
TkMenuEntry *cascadeEntryPtr;
|
||
TkMenu *cascadeMenuPtr;
|
||
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.
|
||
*/
|
||
|
||
if (mePtr->childMenuRefPtr != NULL) {
|
||
oldHashKey = Tcl_GetHashKey(TkGetMenuHashTable(menuPtr->interp),
|
||
mePtr->childMenuRefPtr->hashEntryPtr);
|
||
if (strcmp(oldHashKey, mePtr->name) != 0) {
|
||
UnhookCascadeEntry(mePtr);
|
||
}
|
||
}
|
||
|
||
if ((mePtr->childMenuRefPtr == NULL)
|
||
|| (strcmp(oldHashKey, mePtr->name) != 0)) {
|
||
menuRefPtr = TkCreateMenuReferences(menuPtr->interp,
|
||
mePtr->name);
|
||
cascadeMenuPtr = menuRefPtr->menuPtr;
|
||
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;
|
||
}
|
||
|
||
if (TkpConfigureMenuEntry(mePtr) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if ((mePtr->type == CHECK_BUTTON_ENTRY)
|
||
|| (mePtr->type == RADIO_BUTTON_ENTRY)) {
|
||
char *value;
|
||
|
||
if (mePtr->name == NULL) {
|
||
mePtr->name =
|
||
(char *) ckalloc((unsigned) (mePtr->labelLength + 1));
|
||
strcpy(mePtr->name, (mePtr->label == NULL) ? "" : mePtr->label);
|
||
}
|
||
if (mePtr->onValue == NULL) {
|
||
mePtr->onValue = (char *) ckalloc((unsigned)
|
||
(mePtr->labelLength + 1));
|
||
strcpy(mePtr->onValue, (mePtr->label == NULL) ? "" : mePtr->label);
|
||
}
|
||
|
||
/*
|
||
* 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.
|
||
*/
|
||
|
||
#ifdef SCM_CODE
|
||
value = STk_tcl_getvar(mePtr->name, mePtr->env);
|
||
#else
|
||
value = Tcl_GetVar(menuPtr->interp, mePtr->name, TCL_GLOBAL_ONLY);
|
||
#endif
|
||
mePtr->entryFlags &= ~ENTRY_SELECTED;
|
||
if (value != NULL) {
|
||
if (strcmp(value, mePtr->onValue) == 0) {
|
||
mePtr->entryFlags |= ENTRY_SELECTED;
|
||
}
|
||
} else {
|
||
#ifdef SCM_CODE
|
||
STk_tcl_setvar(mePtr->name,
|
||
(mePtr->type == CHECK_BUTTON_ENTRY) ? mePtr->offValue : "#f",
|
||
0,
|
||
mePtr->env);
|
||
#else
|
||
Tcl_SetVar(menuPtr->interp, mePtr->name,
|
||
(mePtr->type == CHECK_BUTTON_ENTRY) ? mePtr->offValue : "",
|
||
TCL_GLOBAL_ONLY);
|
||
#endif
|
||
}
|
||
Tcl_TraceVar(menuPtr->interp, mePtr->name,
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
MenuVarProc, (ClientData) mePtr);
|
||
}
|
||
|
||
/*
|
||
* 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->imageString != NULL) {
|
||
image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, mePtr->imageString,
|
||
TkMenuImageProc, (ClientData) mePtr);
|
||
if (image == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else {
|
||
image = NULL;
|
||
}
|
||
if (mePtr->image != NULL) {
|
||
Tk_FreeImage(mePtr->image);
|
||
}
|
||
mePtr->image = image;
|
||
if (mePtr->selectImageString != NULL) {
|
||
image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, mePtr->selectImageString,
|
||
TkMenuSelectImageProc, (ClientData) mePtr);
|
||
if (image == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else {
|
||
image = NULL;
|
||
}
|
||
if (mePtr->selectImage != NULL) {
|
||
Tk_FreeImage(mePtr->selectImage);
|
||
}
|
||
mePtr->selectImage = image;
|
||
|
||
TkEventuallyRecomputeMenu(menuPtr);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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 interp->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(interp, menuPtr, index, argc, argv, flags)
|
||
Tcl_Interp *interp; /* Used for error reporting. */
|
||
TkMenu *menuPtr; /* Information about whole menu. */
|
||
int index; /* Index of mePtr within menuPtr's
|
||
* entries. */
|
||
int argc; /* Number of valid entries in argv. */
|
||
char **argv; /* Arguments. */
|
||
int flags; /* Additional flags to pass to
|
||
* Tk_ConfigureWidget. */
|
||
{
|
||
TkMenuEntry *mePtr;
|
||
TkMenu *menuListPtr;
|
||
char *oldCascadeName = NULL, *newMenuName = NULL;
|
||
int cascadeEntryChanged;
|
||
TkMenuReferences *oldCascadeMenuRefPtr, *cascadeMenuRefPtr = NULL;
|
||
|
||
/*
|
||
* 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) {
|
||
oldCascadeName = mePtr->name;
|
||
}
|
||
|
||
if (ConfigureMenuEntry(mePtr, argc, argv, flags) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
cascadeEntryChanged = (mePtr->type == CASCADE_ENTRY)
|
||
&& (oldCascadeName != mePtr->name);
|
||
|
||
if (cascadeEntryChanged) {
|
||
newMenuName = mePtr->name;
|
||
if (newMenuName != NULL) {
|
||
cascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp,
|
||
mePtr->name);
|
||
}
|
||
}
|
||
|
||
for (menuListPtr = menuPtr->masterMenuPtr->nextInstancePtr;
|
||
menuListPtr != NULL;
|
||
menuListPtr = menuListPtr->nextInstancePtr) {
|
||
|
||
mePtr = menuListPtr->entries[index];
|
||
|
||
if (cascadeEntryChanged && (mePtr->name != NULL)) {
|
||
oldCascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp,
|
||
mePtr->name);
|
||
|
||
if ((oldCascadeMenuRefPtr != NULL)
|
||
&& (oldCascadeMenuRefPtr->menuPtr != NULL)) {
|
||
RecursivelyDeleteMenu(oldCascadeMenuRefPtr->menuPtr);
|
||
}
|
||
}
|
||
|
||
if (ConfigureMenuEntry(mePtr, argc, argv, flags) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (cascadeEntryChanged && (newMenuName != NULL)) {
|
||
if (cascadeMenuRefPtr->menuPtr != NULL) {
|
||
char *newArgV[2];
|
||
char *newCloneName;
|
||
|
||
newCloneName = TkNewMenuName(menuPtr->interp,
|
||
Tk_PathName(menuListPtr->tkwin),
|
||
cascadeMenuRefPtr->menuPtr);
|
||
CloneMenu(cascadeMenuRefPtr->menuPtr, newCloneName,
|
||
"normal");
|
||
|
||
newArgV[0] = "-menu";
|
||
newArgV[1] = newCloneName;
|
||
ConfigureMenuEntry(mePtr, 2, newArgV, flags);
|
||
ckfree(newCloneName);
|
||
}
|
||
}
|
||
}
|
||
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 interp->result.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*--------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TkGetMenuIndex(interp, menuPtr, string, lastOK, indexPtr)
|
||
Tcl_Interp *interp; /* For error messages. */
|
||
TkMenu *menuPtr; /* Menu for which the index is being
|
||
* specified. */
|
||
char *string; /* 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 relief. */
|
||
{
|
||
int i;
|
||
|
||
if ((string[0] == 'a') && (strcmp(string, "active") == 0)) {
|
||
*indexPtr = menuPtr->active;
|
||
return TCL_OK;
|
||
}
|
||
|
||
if (((string[0] == 'l') && (strcmp(string, "last") == 0))
|
||
|| ((string[0] == 'e') && (strcmp(string, "end") == 0))) {
|
||
*indexPtr = menuPtr->numEntries - ((lastOK) ? 0 : 1);
|
||
return TCL_OK;
|
||
}
|
||
|
||
if ((string[0] == 'n') && (strcmp(string, "none") == 0)) {
|
||
*indexPtr = -1;
|
||
return TCL_OK;
|
||
}
|
||
|
||
if (string[0] == '@') {
|
||
if (GetIndexFromCoords(interp, menuPtr, string, indexPtr)
|
||
== TCL_OK) {
|
||
return TCL_OK;
|
||
}
|
||
}
|
||
|
||
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;
|
||
return TCL_OK;
|
||
}
|
||
Tcl_SetResult(interp, (char *) NULL, TCL_STATIC);
|
||
}
|
||
|
||
for (i = 0; i < menuPtr->numEntries; i++) {
|
||
char *label;
|
||
|
||
label = menuPtr->entries[i]->label;
|
||
if ((label != NULL)
|
||
&& (Tcl_StringMatch(menuPtr->entries[i]->label, string))) {
|
||
*indexPtr = i;
|
||
return TCL_OK;
|
||
}
|
||
}
|
||
|
||
Tcl_AppendResult(interp, "bad menu entry index \"",
|
||
string, "\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* MenuCmdDeletedProc --
|
||
*
|
||
* This procedure 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 clientData; /* Pointer to widget record for widget. */
|
||
{
|
||
TkMenu *menuPtr = (TkMenu *) clientData;
|
||
Tk_Window tkwin = menuPtr->tkwin;
|
||
|
||
/*
|
||
* This procedure 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 procedure
|
||
* destroys the widget.
|
||
*/
|
||
|
||
if (tkwin != NULL) {
|
||
menuPtr->tkwin = NULL;
|
||
Tk_DestroyWindow(tkwin);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* MenuNewEntry --
|
||
*
|
||
* This procedure 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(menuPtr, index, type)
|
||
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;
|
||
|
||
/*
|
||
* Create a new array of entries with an empty slot for the
|
||
* new entry.
|
||
*/
|
||
|
||
newEntries = (TkMenuEntry **) ckalloc((unsigned)
|
||
((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((char *) menuPtr->entries);
|
||
}
|
||
menuPtr->entries = newEntries;
|
||
menuPtr->numEntries++;
|
||
mePtr = (TkMenuEntry *) ckalloc(sizeof(TkMenuEntry));
|
||
menuPtr->entries[index] = mePtr;
|
||
mePtr->type = type;
|
||
mePtr->menuPtr = menuPtr;
|
||
mePtr->label = NULL;
|
||
mePtr->labelLength = 0;
|
||
mePtr->underline = -1;
|
||
mePtr->bitmap = None;
|
||
mePtr->imageString = NULL;
|
||
mePtr->image = NULL;
|
||
mePtr->selectImageString = NULL;
|
||
mePtr->selectImage = NULL;
|
||
mePtr->accel = NULL;
|
||
mePtr->accelLength = 0;
|
||
mePtr->state = tkNormalUid;
|
||
mePtr->border = NULL;
|
||
mePtr->fg = NULL;
|
||
mePtr->activeBorder = NULL;
|
||
mePtr->activeFg = NULL;
|
||
mePtr->tkfont = NULL;
|
||
mePtr->indicatorOn = 1;
|
||
mePtr->indicatorFg = NULL;
|
||
mePtr->columnBreak = 0;
|
||
mePtr->hideMargin = 0;
|
||
mePtr->command = NULL;
|
||
mePtr->name = NULL;
|
||
mePtr->childMenuRefPtr = NULL;
|
||
mePtr->onValue = NULL;
|
||
mePtr->offValue = NULL;
|
||
mePtr->entryFlags = 0;
|
||
mePtr->index = index;
|
||
mePtr->nextCascadePtr = NULL;
|
||
#ifdef SCM_CODE
|
||
mePtr->env = NULL;
|
||
#endif
|
||
TkMenuInitializeEntryDrawingFields(mePtr);
|
||
if (TkpMenuNewEntry(mePtr) != TCL_OK) {
|
||
ckfree((char *) mePtr);
|
||
return NULL;
|
||
}
|
||
|
||
return mePtr;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* MenuAddOrInsert --
|
||
*
|
||
* This procedure 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(interp, menuPtr, indexString, argc, argv)
|
||
Tcl_Interp *interp; /* Used for error reporting. */
|
||
TkMenu *menuPtr; /* Widget in which to create new
|
||
* entry. */
|
||
char *indexString; /* String describing index at which
|
||
* to insert. NULL means insert at
|
||
* end. */
|
||
int argc; /* Number of elements in argv. */
|
||
char **argv; /* Arguments to command: first arg
|
||
* is type of entry, others are
|
||
* config options. */
|
||
{
|
||
int c, type, index;
|
||
size_t length;
|
||
TkMenuEntry *mePtr;
|
||
TkMenu *menuListPtr;
|
||
|
||
if (indexString != NULL) {
|
||
if (TkGetMenuIndex(interp, menuPtr, indexString, 1, &index)
|
||
!= TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else {
|
||
index = menuPtr->numEntries;
|
||
}
|
||
if (index < 0) {
|
||
Tcl_AppendResult(interp, "bad index \"", indexString, "\"",
|
||
(char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
if (menuPtr->tearOff && (index == 0)) {
|
||
index = 1;
|
||
}
|
||
|
||
/*
|
||
* Figure out the type of the new entry.
|
||
*/
|
||
|
||
c = argv[0][0];
|
||
length = strlen(argv[0]);
|
||
if ((c == 'c') && (strncmp(argv[0], "cascade", length) == 0)
|
||
&& (length >= 2)) {
|
||
type = CASCADE_ENTRY;
|
||
} else if ((c == 'c') && (strncmp(argv[0], "checkbutton", length) == 0)
|
||
&& (length >= 2)) {
|
||
type = CHECK_BUTTON_ENTRY;
|
||
} else if ((c == 'c') && (strncmp(argv[0], "command", length) == 0)
|
||
&& (length >= 2)) {
|
||
type = COMMAND_ENTRY;
|
||
} else if ((c == 'r')
|
||
&& (strncmp(argv[0], "radiobutton", length) == 0)) {
|
||
type = RADIO_BUTTON_ENTRY;
|
||
} else if ((c == 's')
|
||
&& (strncmp(argv[0], "separator", length) == 0)) {
|
||
type = SEPARATOR_ENTRY;
|
||
} else {
|
||
Tcl_AppendResult(interp, "bad menu entry type \"",
|
||
argv[0], "\": must be cascade, checkbutton, ",
|
||
"command, radiobutton, or separator", (char *) NULL);
|
||
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, argc-1, argv+1, 0) != TCL_OK) {
|
||
TkMenu *errorMenuPtr;
|
||
int i;
|
||
|
||
for (errorMenuPtr = menuPtr->masterMenuPtr;
|
||
errorMenuPtr != NULL;
|
||
errorMenuPtr = errorMenuPtr->nextInstancePtr) {
|
||
Tcl_EventuallyFree((ClientData) errorMenuPtr->entries[index],
|
||
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((char *) 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->name != NULL) && (mePtr->childMenuRefPtr != NULL)
|
||
&& (mePtr->childMenuRefPtr->menuPtr != NULL)) {
|
||
TkMenu *cascadeMenuPtr =
|
||
mePtr->childMenuRefPtr->menuPtr->masterMenuPtr;
|
||
char *newCascadeName;
|
||
char *newArgv[2];
|
||
TkMenuReferences *menuRefPtr;
|
||
|
||
newCascadeName = TkNewMenuName(menuListPtr->interp,
|
||
Tk_PathName(menuListPtr->tkwin),
|
||
cascadeMenuPtr);
|
||
CloneMenu(cascadeMenuPtr, newCascadeName, "normal");
|
||
|
||
menuRefPtr = TkFindMenuReferences(menuListPtr->interp,
|
||
newCascadeName);
|
||
if (menuRefPtr == NULL) {
|
||
panic("CloneMenu failed inside of MenuAddOrInsert.");
|
||
}
|
||
newArgv[0] = "-menu";
|
||
newArgv[1] = newCascadeName;
|
||
ConfigureMenuEntry(mePtr, 2, newArgv, 0);
|
||
ckfree(newCascadeName);
|
||
}
|
||
}
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*--------------------------------------------------------------
|
||
*
|
||
* MenuVarProc --
|
||
*
|
||
* This procedure 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, interp, name1, name2, flags)
|
||
ClientData clientData; /* Information about menu entry. */
|
||
Tcl_Interp *interp; /* Interpreter containing variable. */
|
||
char *name1; /* First part of variable's name. */
|
||
char *name2; /* Second part of variable's name. */
|
||
int flags; /* Describes what just happened. */
|
||
{
|
||
TkMenuEntry *mePtr = (TkMenuEntry *) clientData;
|
||
TkMenu *menuPtr;
|
||
char *value;
|
||
|
||
menuPtr = mePtr->menuPtr;
|
||
|
||
/*
|
||
* If the variable is being unset, then re-establish the
|
||
* trace unless the whole interpreter is going away.
|
||
*/
|
||
|
||
if (flags & TCL_TRACE_UNSETS) {
|
||
mePtr->entryFlags &= ~ENTRY_SELECTED;
|
||
if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
|
||
Tcl_TraceVar(interp, mePtr->name,
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
MenuVarProc, clientData);
|
||
}
|
||
TkpConfigureMenuEntry(mePtr);
|
||
TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL);
|
||
return (char *) NULL;
|
||
}
|
||
|
||
/*
|
||
* Use the value of the variable to update the selected status of
|
||
* the menu entry.
|
||
*/
|
||
|
||
#ifdef SCM_CODE
|
||
value = STk_tcl_getvar(mePtr->name, mePtr->env);
|
||
#else
|
||
value = Tcl_GetVar(interp, mePtr->name, TCL_GLOBAL_ONLY);
|
||
#endif
|
||
if (value == NULL) {
|
||
value = "";
|
||
}
|
||
if (strcmp(value, mePtr->onValue) == 0) {
|
||
if (mePtr->entryFlags & ENTRY_SELECTED) {
|
||
return (char *) NULL;
|
||
}
|
||
mePtr->entryFlags |= ENTRY_SELECTED;
|
||
} else if (mePtr->entryFlags & ENTRY_SELECTED) {
|
||
mePtr->entryFlags &= ~ENTRY_SELECTED;
|
||
} else {
|
||
return (char *) NULL;
|
||
}
|
||
TkpConfigureMenuEntry(mePtr);
|
||
TkEventuallyRedrawMenu(menuPtr, mePtr);
|
||
return (char *) NULL;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TkActivateMenuEntry --
|
||
*
|
||
* This procedure 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(menuPtr, index)
|
||
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 == tkActiveUid) {
|
||
mePtr->state = tkNormalUid;
|
||
}
|
||
TkEventuallyRedrawMenu(menuPtr, menuPtr->entries[menuPtr->active]);
|
||
}
|
||
menuPtr->active = index;
|
||
if (index >= 0) {
|
||
mePtr = menuPtr->entries[index];
|
||
mePtr->state = tkActiveUid;
|
||
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(menuPtr)
|
||
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->postCommand != NULL) {
|
||
result = TkCopyAndGlobalEval(menuPtr->interp,
|
||
menuPtr->postCommand);
|
||
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.
|
||
*
|
||
*---------------------------------------- |