/[dtapublic]/projs/trunk/shared_source/c_tk_base_7_5_w_mods/tkmenu.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tk_base_7_5_w_mods/tkmenu.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 69 - (show annotations) (download)
Sat Nov 5 10:54:17 2016 UTC (6 years, 3 months ago) by dashley
File MIME type: text/plain
File size: 108346 byte(s)
License and property (keyword) changes.
1 /* $Header$ */
2
3 /*
4 * tkMenu.c --
5 *
6 * This file contains most of the code for implementing menus in Tk. It takes
7 * care of all of the generic (platform-independent) parts of menus, and
8 * is supplemented by platform-specific files. The geometry calculation
9 * and drawing code for menus is in the file tkMenuDraw.c
10 *
11 * Copyright (c) 1990-1994 The Regents of the University of California.
12 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
13 *
14 * See the file "license.terms" for information on usage and redistribution
15 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16 *
17 * RCS: @(#) $Id: tkmenu.c,v 1.1.1.1 2001/06/13 05:05:37 dtashley Exp $
18 */
19
20 /*
21 * Notes on implementation of menus:
22 *
23 * Menus can be used in three ways:
24 * - as a popup menu, either as part of a menubutton or standalone.
25 * - as a menubar. The menu's cascade items are arranged according to
26 * the specific platform to provide the user access to the menus at all
27 * times
28 * - as a tearoff palette. This is a window with the menu's items in it.
29 *
30 * The goal is to provide the Tk developer with a way to use a common
31 * set of menus for all of these tasks.
32 *
33 * In order to make the bindings for cascade menus work properly under Unix,
34 * the cascade menus' pathnames must be proper children of the menu that
35 * they are cascade from. So if there is a menu .m, and it has two
36 * cascades labelled "File" and "Edit", the cascade menus might have
37 * the pathnames .m.file and .m.edit. Another constraint is that the menus
38 * used for menubars must be children of the toplevel widget that they
39 * are attached to. And on the Macintosh, the platform specific menu handle
40 * for cascades attached to a menu bar must have a title that matches the
41 * label for the cascade menu.
42 *
43 * To handle all of the constraints, Tk menubars and tearoff menus are
44 * implemented using menu clones. Menu clones are full menus in their own
45 * right; they have a Tk window and pathname associated with them; they have
46 * a TkMenu structure and array of entries. However, they are linked with the
47 * original menu that they were cloned from. The reflect the attributes of
48 * the original, or "master", menu. So if an item is added to a menu, and
49 * that menu has clones, then the item must be added to all of its clones
50 * also. Menus are cloned when a menu is torn-off or when a menu is assigned
51 * as a menubar using the "-menu" option of the toplevel's pathname configure
52 * subcommand. When a clone is destroyed, only the clone is destroyed, but
53 * when the master menu is destroyed, all clones are also destroyed. This
54 * allows the developer to just deal with one set of menus when creating
55 * and destroying.
56 *
57 * Clones are rather tricky when a menu with cascade entries is cloned (such
58 * as a menubar). Not only does the menu have to be cloned, but each cascade
59 * entry's corresponding menu must also be cloned. This maintains the pathname
60 * parent-child hierarchy necessary for menubars and toplevels to work.
61 * This leads to several special cases:
62 *
63 * 1. When a new menu is created, and it is pointed to by cascade entries in
64 * cloned menus, the new menu has to be cloned to parallel the cascade
65 * structure.
66 * 2. When a cascade item is added to a menu that has been cloned, and the
67 * menu that the cascade item points to exists, that menu has to be cloned.
68 * 3. When the menu that a cascade entry points to is changed, the old
69 * cloned cascade menu has to be discarded, and the new one has to be cloned.
70 *
71 */
72
73 #if 0
74
75 /*
76 * used only to test for old config code
77 */
78
79 #define __NO_OLD_CONFIG
80 #endif
81
82 #include "tkPort.h"
83 #include "tkMenu.h"
84
85 #define MENU_HASH_KEY "tkMenus"
86
87 typedef struct ThreadSpecificData {
88 int menusInitialized; /* Flag indicates whether thread-specific
89 * elements of the Windows Menu module
90 * have been initialized. */
91 } ThreadSpecificData;
92 static Tcl_ThreadDataKey dataKey;
93
94 /*
95 * The following flag indicates whether the process-wide state for
96 * the Menu module has been intialized. The Mutex protects access to
97 * that flag.
98 */
99
100 static int menusInitialized;
101 TCL_DECLARE_MUTEX(menuMutex)
102
103 /*
104 * Configuration specs for individual menu entries. If this changes, be sure
105 * to update code in TkpMenuInit that changes the font string entry.
106 */
107
108 char *tkMenuStateStrings[] = {"active", "normal", "disabled", (char *) NULL};
109
110 static char *menuEntryTypeStrings[] = {"cascade", "checkbutton", "command",
111 "radiobutton", "separator", (char *) NULL};
112
113 Tk_OptionSpec tkBasicMenuEntryConfigSpecs[] = {
114 {TK_OPTION_BORDER, "-activebackground", (char *) NULL, (char *) NULL,
115 DEF_MENU_ENTRY_ACTIVE_BG, Tk_Offset(TkMenuEntry, activeBorderPtr), -1,
116 TK_OPTION_NULL_OK},
117 {TK_OPTION_COLOR, "-activeforeground", (char *) NULL, (char *) NULL,
118 DEF_MENU_ENTRY_ACTIVE_FG,
119 Tk_Offset(TkMenuEntry, activeFgPtr), -1, TK_OPTION_NULL_OK},
120 {TK_OPTION_STRING, "-accelerator", (char *) NULL, (char *) NULL,
121 DEF_MENU_ENTRY_ACCELERATOR,
122 Tk_Offset(TkMenuEntry, accelPtr), -1, TK_OPTION_NULL_OK},
123 {TK_OPTION_BORDER, "-background", (char *) NULL, (char *) NULL,
124 DEF_MENU_ENTRY_BG,
125 Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK},
126 {TK_OPTION_BITMAP, "-bitmap", (char *) NULL, (char *) NULL,
127 DEF_MENU_ENTRY_BITMAP,
128 Tk_Offset(TkMenuEntry, bitmapPtr), -1, TK_OPTION_NULL_OK},
129 {TK_OPTION_BOOLEAN, "-columnbreak", (char *) NULL, (char *) NULL,
130 DEF_MENU_ENTRY_COLUMN_BREAK,
131 -1, Tk_Offset(TkMenuEntry, columnBreak)},
132 {TK_OPTION_STRING, "-command", (char *) NULL, (char *) NULL,
133 DEF_MENU_ENTRY_COMMAND,
134 Tk_Offset(TkMenuEntry, commandPtr), -1, TK_OPTION_NULL_OK},
135 {TK_OPTION_FONT, "-font", (char *) NULL, (char *) NULL,
136 DEF_MENU_ENTRY_FONT,
137 Tk_Offset(TkMenuEntry, fontPtr), -1, TK_OPTION_NULL_OK},
138 {TK_OPTION_COLOR, "-foreground", (char *) NULL, (char *) NULL,
139 DEF_MENU_ENTRY_FG,
140 Tk_Offset(TkMenuEntry, fgPtr), -1, TK_OPTION_NULL_OK},
141 {TK_OPTION_BOOLEAN, "-hidemargin", (char *) NULL, (char *) NULL,
142 DEF_MENU_ENTRY_HIDE_MARGIN,
143 -1, Tk_Offset(TkMenuEntry, hideMargin)},
144 {TK_OPTION_STRING, "-image", (char *) NULL, (char *) NULL,
145 DEF_MENU_ENTRY_IMAGE,
146 Tk_Offset(TkMenuEntry, imagePtr), -1, TK_OPTION_NULL_OK},
147 {TK_OPTION_STRING, "-label", (char *) NULL, (char *) NULL,
148 DEF_MENU_ENTRY_LABEL,
149 Tk_Offset(TkMenuEntry, labelPtr), -1, 0},
150 {TK_OPTION_STRING_TABLE, "-state", (char *) NULL, (char *) NULL,
151 DEF_MENU_ENTRY_STATE,
152 -1, Tk_Offset(TkMenuEntry, state), 0,
153 (ClientData) tkMenuStateStrings},
154 {TK_OPTION_INT, "-underline", (char *) NULL, (char *) NULL,
155 DEF_MENU_ENTRY_UNDERLINE, -1, Tk_Offset(TkMenuEntry, underline)},
156 {TK_OPTION_END}
157 };
158
159 Tk_OptionSpec tkSeparatorEntryConfigSpecs[] = {
160 {TK_OPTION_BORDER, "-background", (char *) NULL, (char *) NULL,
161 DEF_MENU_ENTRY_BG,
162 Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK},
163 {TK_OPTION_END}
164 };
165
166 Tk_OptionSpec tkCheckButtonEntryConfigSpecs[] = {
167 {TK_OPTION_BOOLEAN, "-indicatoron", (char *) NULL, (char *) NULL,
168 DEF_MENU_ENTRY_INDICATOR,
169 -1, Tk_Offset(TkMenuEntry, indicatorOn)},
170 {TK_OPTION_STRING, "-offvalue", (char *) NULL, (char *) NULL,
171 DEF_MENU_ENTRY_OFF_VALUE,
172 Tk_Offset(TkMenuEntry, offValuePtr), -1},
173 {TK_OPTION_STRING, "-onvalue", (char *) NULL, (char *) NULL,
174 DEF_MENU_ENTRY_ON_VALUE,
175 Tk_Offset(TkMenuEntry, onValuePtr), -1},
176 {TK_OPTION_COLOR, "-selectcolor", (char *) NULL, (char *) NULL,
177 DEF_MENU_ENTRY_SELECT,
178 Tk_Offset(TkMenuEntry, indicatorFgPtr), -1, TK_OPTION_NULL_OK},
179 {TK_OPTION_STRING, "-selectimage", (char *) NULL, (char *) NULL,
180 DEF_MENU_ENTRY_SELECT_IMAGE,
181 Tk_Offset(TkMenuEntry, selectImagePtr), -1, TK_OPTION_NULL_OK},
182 {TK_OPTION_STRING, "-variable", (char *) NULL, (char *) NULL,
183 DEF_MENU_ENTRY_CHECK_VARIABLE,
184 Tk_Offset(TkMenuEntry, namePtr), -1, TK_OPTION_NULL_OK},
185 {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL,
186 (char *) NULL, 0, -1, 0, (ClientData) tkBasicMenuEntryConfigSpecs}
187 };
188
189 Tk_OptionSpec tkRadioButtonEntryConfigSpecs[] = {
190 {TK_OPTION_BOOLEAN, "-indicatoron", (char *) NULL, (char *) NULL,
191 DEF_MENU_ENTRY_INDICATOR,
192 -1, Tk_Offset(TkMenuEntry, indicatorOn)},
193 {TK_OPTION_COLOR, "-selectcolor", (char *) NULL, (char *) NULL,
194 DEF_MENU_ENTRY_SELECT,
195 Tk_Offset(TkMenuEntry, indicatorFgPtr), -1, TK_OPTION_NULL_OK},
196 {TK_OPTION_STRING, "-selectimage", (char *) NULL, (char *) NULL,
197 DEF_MENU_ENTRY_SELECT_IMAGE,
198 Tk_Offset(TkMenuEntry, selectImagePtr), -1, TK_OPTION_NULL_OK},
199 {TK_OPTION_STRING, "-value", (char *) NULL, (char *) NULL,
200 DEF_MENU_ENTRY_VALUE,
201 Tk_Offset(TkMenuEntry, onValuePtr), -1, TK_OPTION_NULL_OK},
202 {TK_OPTION_STRING, "-variable", (char *) NULL, (char *) NULL,
203 DEF_MENU_ENTRY_RADIO_VARIABLE,
204 Tk_Offset(TkMenuEntry, namePtr), -1, 0},
205 {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL,
206 (char *) NULL, 0, -1, 0, (ClientData) tkBasicMenuEntryConfigSpecs}
207 };
208
209 Tk_OptionSpec tkCascadeEntryConfigSpecs[] = {
210 {TK_OPTION_STRING, "-menu", (char *) NULL, (char *) NULL,
211 DEF_MENU_ENTRY_MENU,
212 Tk_Offset(TkMenuEntry, namePtr), -1, TK_OPTION_NULL_OK},
213 {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL,
214 (char *) NULL, 0, -1, 0, (ClientData) tkBasicMenuEntryConfigSpecs}
215 };
216
217 Tk_OptionSpec tkTearoffEntryConfigSpecs[] = {
218 {TK_OPTION_BORDER, "-background", (char *) NULL, (char *) NULL,
219 DEF_MENU_ENTRY_BG,
220 Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK},
221 {TK_OPTION_STRING_TABLE, "-state", (char *) NULL, (char *) NULL,
222 DEF_MENU_ENTRY_STATE, -1, Tk_Offset(TkMenuEntry, state), 0,
223 (ClientData) tkMenuStateStrings},
224 {TK_OPTION_END}
225 };
226
227 static Tk_OptionSpec *specsArray[] = {
228 tkCascadeEntryConfigSpecs, tkCheckButtonEntryConfigSpecs,
229 tkBasicMenuEntryConfigSpecs, tkRadioButtonEntryConfigSpecs,
230 tkSeparatorEntryConfigSpecs, tkTearoffEntryConfigSpecs};
231
232 /*
233 * Menu type strings for use with Tcl_GetIndexFromObj.
234 */
235
236 static char *menuTypeStrings[] = {"normal", "tearoff", "menubar",
237 (char *) NULL};
238
239 Tk_OptionSpec tkMenuConfigSpecs[] = {
240 {TK_OPTION_BORDER, "-activebackground", "activeBackground",
241 "Foreground", DEF_MENU_ACTIVE_BG_COLOR,
242 Tk_Offset(TkMenu, activeBorderPtr), -1, 0,
243 (ClientData) DEF_MENU_ACTIVE_BG_MONO},
244 {TK_OPTION_PIXELS, "-activeborderwidth", "activeBorderWidth",
245 "BorderWidth", DEF_MENU_ACTIVE_BORDER_WIDTH,
246 Tk_Offset(TkMenu, activeBorderWidthPtr), -1},
247 {TK_OPTION_COLOR, "-activeforeground", "activeForeground",
248 "Background", DEF_MENU_ACTIVE_FG_COLOR,
249 Tk_Offset(TkMenu, activeFgPtr), -1, 0,
250 (ClientData) DEF_MENU_ACTIVE_FG_MONO},
251 {TK_OPTION_BORDER, "-background", "background", "Background",
252 DEF_MENU_BG_COLOR, Tk_Offset(TkMenu, borderPtr), -1, 0,
253 (ClientData) DEF_MENU_BG_MONO},
254 {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL,
255 (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth"},
256 {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL,
257 (char *) NULL, 0, -1, 0, (ClientData) "-background"},
258 {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth",
259 DEF_MENU_BORDER_WIDTH,
260 Tk_Offset(TkMenu, borderWidthPtr), -1, 0},
261 {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor",
262 DEF_MENU_CURSOR,
263 Tk_Offset(TkMenu, cursorPtr), -1, TK_OPTION_NULL_OK},
264 {TK_OPTION_COLOR, "-disabledforeground", "disabledForeground",
265 "DisabledForeground", DEF_MENU_DISABLED_FG_COLOR,
266 Tk_Offset(TkMenu, disabledFgPtr), -1, TK_OPTION_NULL_OK,
267 (ClientData) DEF_MENU_DISABLED_FG_MONO},
268 {TK_OPTION_SYNONYM, "-fg", (char *) NULL, (char *) NULL,
269 (char *) NULL, 0, -1, 0, (ClientData) "-foreground"},
270 {TK_OPTION_FONT, "-font", "font", "Font",
271 DEF_MENU_FONT, Tk_Offset(TkMenu, fontPtr), -1},
272 {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground",
273 DEF_MENU_FG, Tk_Offset(TkMenu, fgPtr), -1},
274 {TK_OPTION_STRING, "-postcommand", "postCommand", "Command",
275 DEF_MENU_POST_COMMAND,
276 Tk_Offset(TkMenu, postCommandPtr), -1, TK_OPTION_NULL_OK},
277 {TK_OPTION_RELIEF, "-relief", "relief", "Relief",
278 DEF_MENU_RELIEF, Tk_Offset(TkMenu, reliefPtr), -1},
279 {TK_OPTION_COLOR, "-selectcolor", "selectColor", "Background",
280 DEF_MENU_SELECT_COLOR, Tk_Offset(TkMenu, indicatorFgPtr), -1, 0,
281 (ClientData) DEF_MENU_SELECT_MONO},
282 {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus",
283 DEF_MENU_TAKE_FOCUS,
284 Tk_Offset(TkMenu, takeFocusPtr), -1, TK_OPTION_NULL_OK},
285 {TK_OPTION_BOOLEAN, "-tearoff", "tearOff", "TearOff",
286 DEF_MENU_TEAROFF, -1, Tk_Offset(TkMenu, tearoff)},
287 {TK_OPTION_STRING, "-tearoffcommand", "tearOffCommand",
288 "TearOffCommand", DEF_MENU_TEAROFF_CMD,
289 Tk_Offset(TkMenu, tearoffCommandPtr), -1, TK_OPTION_NULL_OK},
290 {TK_OPTION_STRING, "-title", "title", "Title",
291 DEF_MENU_TITLE, Tk_Offset(TkMenu, titlePtr), -1,
292 TK_OPTION_NULL_OK},
293 {TK_OPTION_STRING_TABLE, "-type", "type", "Type",
294 DEF_MENU_TYPE, Tk_Offset(TkMenu, menuTypePtr), -1, TK_OPTION_NULL_OK,
295 (ClientData) menuTypeStrings},
296 {TK_OPTION_END}
297 };
298
299 /*
300 * Command line options. Put here because MenuCmd has to look at them
301 * along with MenuWidgetObjCmd.
302 */
303
304 static char *menuOptions[] = {
305 "activate", "add", "cget", "clone", "configure", "delete", "entrycget",
306 "entryconfigure", "index", "insert", "invoke", "post", "postcascade",
307 "type", "unpost", "yposition", (char *) NULL
308 };
309 enum options {
310 MENU_ACTIVATE, MENU_ADD, MENU_CGET, MENU_CLONE, MENU_CONFIGURE,
311 MENU_DELETE, MENU_ENTRYCGET, MENU_ENTRYCONFIGURE, MENU_INDEX,
312 MENU_INSERT, MENU_INVOKE, MENU_POST, MENU_POSTCASCADE, MENU_TYPE,
313 MENU_UNPOST, MENU_YPOSITION
314 };
315
316 /*
317 * Prototypes for static procedures in this file:
318 */
319
320 static int CloneMenu _ANSI_ARGS_((TkMenu *menuPtr,
321 Tcl_Obj *newMenuName, Tcl_Obj *newMenuTypeString));
322 static int ConfigureMenu _ANSI_ARGS_((Tcl_Interp *interp,
323 TkMenu *menuPtr, int objc, Tcl_Obj *CONST objv[]));
324 static int ConfigureMenuCloneEntries _ANSI_ARGS_((
325 Tcl_Interp *interp, TkMenu *menuPtr, int index,
326 int objc, Tcl_Obj *CONST objv[]));
327 static int ConfigureMenuEntry _ANSI_ARGS_((TkMenuEntry *mePtr,
328 int objc, Tcl_Obj *CONST objv[]));
329 static void DeleteMenuCloneEntries _ANSI_ARGS_((TkMenu *menuPtr,
330 int first, int last));
331 static void DestroyMenuHashTable _ANSI_ARGS_((
332 ClientData clientData, Tcl_Interp *interp));
333 static void DestroyMenuInstance _ANSI_ARGS_((TkMenu *menuPtr));
334 static void DestroyMenuEntry _ANSI_ARGS_((char *memPtr));
335 static int GetIndexFromCoords
336 _ANSI_ARGS_((Tcl_Interp *interp, TkMenu *menuPtr,
337 char *string, int *indexPtr));
338 static int MenuDoYPosition _ANSI_ARGS_((Tcl_Interp *interp,
339 TkMenu *menuPtr, Tcl_Obj *objPtr));
340 static int MenuAddOrInsert _ANSI_ARGS_((Tcl_Interp *interp,
341 TkMenu *menuPtr, Tcl_Obj *indexPtr, int objc,
342 Tcl_Obj *CONST objv[]));
343 static int MenuCmd _ANSI_ARGS_((ClientData clientData,
344 Tcl_Interp *interp, int objc,
345 Tcl_Obj *CONST objv[]));
346 static void MenuCmdDeletedProc _ANSI_ARGS_((
347 ClientData clientData));
348 static TkMenuEntry * MenuNewEntry _ANSI_ARGS_((TkMenu *menuPtr, int index,
349 int type));
350 static char * MenuVarProc _ANSI_ARGS_((ClientData clientData,
351 Tcl_Interp *interp, char *name1, char *name2,
352 int flags));
353 static int MenuWidgetObjCmd _ANSI_ARGS_((ClientData clientData,
354 Tcl_Interp *interp, int objc,
355 Tcl_Obj *CONST objv[]));
356 static void MenuWorldChanged _ANSI_ARGS_((
357 ClientData instanceData));
358 static int PostProcessEntry _ANSI_ARGS_((TkMenuEntry *mePtr));
359 static void RecursivelyDeleteMenu _ANSI_ARGS_((TkMenu *menuPtr));
360 static void UnhookCascadeEntry _ANSI_ARGS_((TkMenuEntry *mePtr));
361
362 /*
363 * The structure below is a list of procs that respond to certain window
364 * manager events. One of these includes a font change, which forces
365 * the geometry proc to be called.
366 */
367
368 static TkClassProcs menuClass = {
369 NULL, /* createProc. */
370 MenuWorldChanged /* geometryProc. */
371 };
372
373 /*
374 *--------------------------------------------------------------
375 *
376 * Tk_CreateMenuCmd --
377 *
378 * Called by Tk at initialization time to create the menu
379 * command.
380 *
381 * Results:
382 * A standard Tcl result.
383 *
384 * Side effects:
385 * See the user documentation.
386 *
387 *--------------------------------------------------------------
388 */
389
390 int
391 TkCreateMenuCmd(interp)
392 Tcl_Interp *interp; /* Interpreter we are creating the
393 * command in. */
394 {
395 TkMenuOptionTables *optionTablesPtr =
396 (TkMenuOptionTables *) ckalloc(sizeof(TkMenuOptionTables));
397
398 optionTablesPtr->menuOptionTable =
399 Tk_CreateOptionTable(interp, tkMenuConfigSpecs);
400 optionTablesPtr->entryOptionTables[TEAROFF_ENTRY] =
401 Tk_CreateOptionTable(interp, specsArray[TEAROFF_ENTRY]);
402 optionTablesPtr->entryOptionTables[COMMAND_ENTRY] =
403 Tk_CreateOptionTable(interp, specsArray[COMMAND_ENTRY]);
404 optionTablesPtr->entryOptionTables[CASCADE_ENTRY] =
405 Tk_CreateOptionTable(interp, specsArray[CASCADE_ENTRY]);
406 optionTablesPtr->entryOptionTables[SEPARATOR_ENTRY] =
407 Tk_CreateOptionTable(interp, specsArray[SEPARATOR_ENTRY]);
408 optionTablesPtr->entryOptionTables[RADIO_BUTTON_ENTRY] =
409 Tk_CreateOptionTable(interp, specsArray[RADIO_BUTTON_ENTRY]);
410 optionTablesPtr->entryOptionTables[CHECK_BUTTON_ENTRY] =
411 Tk_CreateOptionTable(interp, specsArray[CHECK_BUTTON_ENTRY]);
412
413 Tcl_CreateObjCommand(interp, "menu", MenuCmd,
414 (ClientData) optionTablesPtr, NULL);
415
416 if (Tcl_IsSafe(interp)) {
417 Tcl_HideCommand(interp, "menu", "menu");
418 }
419
420 return TCL_OK;
421 }
422
423 /*
424 *--------------------------------------------------------------
425 *
426 * MenuCmd --
427 *
428 * This procedure is invoked to process the "menu" Tcl
429 * command. See the user documentation for details on
430 * what it does.
431 *
432 * Results:
433 * A standard Tcl result.
434 *
435 * Side effects:
436 * See the user documentation.
437 *
438 *--------------------------------------------------------------
439 */
440
441 static int
442 MenuCmd(clientData, interp, objc, objv)
443 ClientData clientData; /* Main window associated with
444 * interpreter. */
445 Tcl_Interp *interp; /* Current interpreter. */
446 int objc; /* Number of arguments. */
447 Tcl_Obj *CONST objv[]; /* Argument strings. */
448 {
449 Tk_Window tkwin = Tk_MainWindow(interp);
450 Tk_Window new;
451 register TkMenu *menuPtr;
452 TkMenuReferences *menuRefPtr;
453 int i, index;
454 int toplevel;
455 char *windowName;
456 static char *typeStringList[] = {"-type", (char *) NULL};
457 TkMenuOptionTables *optionTablesPtr = (TkMenuOptionTables *) clientData;
458
459 if (objc < 2) {
460 Tcl_WrongNumArgs(interp, 1, objv, "pathName ?options?");
461 return TCL_ERROR;
462 }
463
464 TkMenuInit();
465
466 toplevel = 1;
467 for (i = 2; i < (objc - 1); i++) {
468 if (Tcl_GetIndexFromObj(NULL, objv[i], typeStringList, NULL, 0, &index)
469 != TCL_ERROR) {
470 if ((Tcl_GetIndexFromObj(NULL, objv[i + 1], menuTypeStrings, NULL,
471 0, &index) == TCL_OK) && (index == MENUBAR)) {
472 toplevel = 0;
473 }
474 break;
475 }
476 }
477
478 windowName = Tcl_GetStringFromObj(objv[1], NULL);
479 new = Tk_CreateWindowFromPath(interp, tkwin, windowName, toplevel ? ""
480 : NULL);
481 if (new == NULL) {
482 return TCL_ERROR;
483 }
484
485 /*
486 * Initialize the data structure for the menu.
487 */
488
489 menuPtr = (TkMenu *) ckalloc(sizeof(TkMenu));
490 menuPtr->tkwin = new;
491 menuPtr->display = Tk_Display(new);
492 menuPtr->interp = interp;
493 menuPtr->widgetCmd = Tcl_CreateObjCommand(interp,
494 Tk_PathName(menuPtr->tkwin), MenuWidgetObjCmd,
495 (ClientData) menuPtr, MenuCmdDeletedProc);
496 menuPtr->entries = NULL;
497 menuPtr->numEntries = 0;
498 menuPtr->active = -1;
499 menuPtr->borderPtr = NULL;
500 menuPtr->borderWidthPtr = NULL;
501 menuPtr->reliefPtr = NULL;
502 menuPtr->activeBorderPtr = NULL;
503 menuPtr->activeBorderWidthPtr = NULL;
504 menuPtr->fontPtr = NULL;
505 menuPtr->fgPtr = NULL;
506 menuPtr->disabledFgPtr = NULL;
507 menuPtr->activeFgPtr = NULL;
508 menuPtr->indicatorFgPtr = NULL;
509 menuPtr->tearoff = 0;
510 menuPtr->tearoffCommandPtr = NULL;
511 menuPtr->cursorPtr = None;
512 menuPtr->takeFocusPtr = NULL;
513 menuPtr->postCommandPtr = NULL;
514 menuPtr->postCommandGeneration = 0;
515 menuPtr->postedCascade = NULL;
516 menuPtr->nextInstancePtr = NULL;
517 menuPtr->masterMenuPtr = menuPtr;
518 menuPtr->menuType = UNKNOWN_TYPE;
519 menuPtr->menuFlags = 0;
520 menuPtr->parentTopLevelPtr = NULL;
521 menuPtr->menuTypePtr = NULL;
522 menuPtr->titlePtr = NULL;
523 menuPtr->errorStructPtr = NULL;
524 menuPtr->optionTablesPtr = optionTablesPtr;
525 TkMenuInitializeDrawingFields(menuPtr);
526
527 Tk_SetClass(menuPtr->tkwin, "Menu");
528 TkSetClassProcs(menuPtr->tkwin, &menuClass, (ClientData) menuPtr);
529 if (Tk_InitOptions(interp, (char *) menuPtr,
530 menuPtr->optionTablesPtr->menuOptionTable, menuPtr->tkwin)
531 != TCL_OK) {
532 Tk_DestroyWindow(menuPtr->tkwin);
533 ckfree((char *) menuPtr);
534 return TCL_ERROR;
535 }
536
537
538 menuRefPtr = TkCreateMenuReferences(menuPtr->interp,
539 Tk_PathName(menuPtr->tkwin));
540 menuRefPtr->menuPtr = menuPtr;
541 menuPtr->menuRefPtr = menuRefPtr;
542 if (TCL_OK != TkpNewMenu(menuPtr)) {
543 Tk_DestroyWindow(menuPtr->tkwin);
544 ckfree((char *) menuPtr);
545 return TCL_ERROR;
546 }
547
548 Tk_CreateEventHandler(new, ExposureMask|StructureNotifyMask|ActivateMask,
549 TkMenuEventProc, (ClientData) menuPtr);
550 if (ConfigureMenu(interp, menuPtr, objc - 2, objv + 2) != TCL_OK) {
551 Tk_DestroyWindow(menuPtr->tkwin);
552 return TCL_ERROR;
553 }
554
555 /*
556 * If a menu has a parent menu pointing to it as a cascade entry, the
557 * parent menu needs to be told that this menu now exists so that
558 * the platform-part of the menu is correctly updated.
559 *
560 * If a menu has an instance and has cascade entries, then each cascade
561 * menu must also have a parallel instance. This is especially true on
562 * the Mac, where each menu has to have a separate title everytime it is in
563 * a menubar. For instance, say you have a menu .m1 with a cascade entry
564 * for .m2, where .m2 does not exist yet. You then put .m1 into a menubar.
565 * This creates a menubar instance for .m1, but since .m2 is not there,
566 * nothing else happens. When we go to create .m2, we hook it up properly
567 * with .m1. However, we now need to clone .m2 and assign the clone of .m2
568 * to be the cascade entry for the clone of .m1. This is special case
569 * #1 listed in the introductory comment.
570 */
571
572 if (menuRefPtr->parentEntryPtr != NULL) {
573 TkMenuEntry *cascadeListPtr = menuRefPtr->parentEntryPtr;
574 TkMenuEntry *nextCascadePtr;
575 Tcl_Obj *newMenuName;
576 Tcl_Obj *newObjv[2];
577
578 while (cascadeListPtr != NULL) {
579
580 nextCascadePtr = cascadeListPtr->nextCascadePtr;
581
582 /*
583 * If we have a new master menu, and an existing cloned menu
584 * points to this menu in a cascade entry, we have to clone
585 * the new menu and point the entry to the clone instead
586 * of the menu we are creating. Otherwise, ConfigureMenuEntry
587 * will hook up the platform-specific cascade linkages now
588 * that the menu we are creating exists.
589 */
590
591 if ((menuPtr->masterMenuPtr != menuPtr)
592 || ((menuPtr->masterMenuPtr == menuPtr)
593 && ((cascadeListPtr->menuPtr->masterMenuPtr
594 == cascadeListPtr->menuPtr)))) {
595 newObjv[0] = Tcl_NewStringObj("-menu", -1);
596 newObjv[1] = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1);
597 Tcl_IncrRefCount(newObjv[0]);
598 Tcl_IncrRefCount(newObjv[1]);
599 ConfigureMenuEntry(cascadeListPtr, 2, newObjv);
600 Tcl_DecrRefCount(newObjv[0]);
601 Tcl_DecrRefCount(newObjv[1]);
602 } else {
603 Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1);
604 Tcl_Obj *windowNamePtr = Tcl_NewStringObj(
605 Tk_PathName(cascadeListPtr->menuPtr->tkwin), -1);
606
607 Tcl_IncrRefCount(normalPtr);
608 Tcl_IncrRefCount(windowNamePtr);
609 newMenuName = TkNewMenuName(menuPtr->interp,
610 windowNamePtr, menuPtr);
611 Tcl_IncrRefCount(newMenuName);
612 CloneMenu(menuPtr, newMenuName, normalPtr);
613
614 /*
615 * Now we can set the new menu instance to be the cascade entry
616 * of the parent's instance.
617 */
618
619 newObjv[0] = Tcl_NewStringObj("-menu", -1);
620 newObjv[1] = newMenuName;
621 Tcl_IncrRefCount(newObjv[0]);
622 ConfigureMenuEntry(cascadeListPtr, 2, newObjv);
623 Tcl_DecrRefCount(normalPtr);
624 Tcl_DecrRefCount(newObjv[0]);
625 Tcl_DecrRefCount(newObjv[1]);
626 Tcl_DecrRefCount(windowNamePtr);
627 }
628 cascadeListPtr = nextCascadePtr;
629 }
630 }
631
632 /*
633 * If there already exist toplevel widgets that refer to this menu,
634 * find them and notify them so that they can reconfigure their
635 * geometry to reflect the menu.
636 */
637
638 if (menuRefPtr->topLevelListPtr != NULL) {
639 TkMenuTopLevelList *topLevelListPtr = menuRefPtr->topLevelListPtr;
640 TkMenuTopLevelList *nextPtr;
641 Tk_Window listtkwin;
642 while (topLevelListPtr != NULL) {
643
644 /*
645 * Need to get the next pointer first. TkSetWindowMenuBar
646 * changes the list, so that the next pointer is different
647 * after calling it.
648 */
649
650 nextPtr = topLevelListPtr->nextPtr;
651 listtkwin = topLevelListPtr->tkwin;
652 TkSetWindowMenuBar(menuPtr->interp, listtkwin,
653 Tk_PathName(menuPtr->tkwin), Tk_PathName(menuPtr->tkwin));
654 topLevelListPtr = nextPtr;
655 }
656 }
657
658 Tcl_SetResult(interp, Tk_PathName(menuPtr->tkwin), TCL_STATIC);
659 return TCL_OK;
660 }
661
662 /*
663 *--------------------------------------------------------------
664 *
665 * MenuWidgetObjCmd --
666 *
667 * This procedure is invoked to process the Tcl command
668 * that corresponds to a widget managed by this module.
669 * See the user documentation for details on what it does.
670 *
671 * Results:
672 * A standard Tcl result.
673 *
674 * Side effects:
675 * See the user documentation.
676 *
677 *--------------------------------------------------------------
678 */
679
680 static int
681 MenuWidgetObjCmd(clientData, interp, objc, objv)
682 ClientData clientData; /* Information about menu widget. */
683 Tcl_Interp *interp; /* Current interpreter. */
684 int objc; /* Number of arguments. */
685 Tcl_Obj *CONST objv[]; /* Argument strings. */
686 {
687 register TkMenu *menuPtr = (TkMenu *) clientData;
688 register TkMenuEntry *mePtr;
689 int result = TCL_OK;
690 int option;
691
692 if (objc < 2) {
693 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
694 return TCL_ERROR;
695 }
696 if (Tcl_GetIndexFromObj(interp, objv[1], menuOptions, "option", 0,
697 &option) != TCL_OK) {
698 return TCL_ERROR;
699 }
700 Tcl_Preserve((ClientData) menuPtr);
701
702 switch ((enum options) option) {
703 case MENU_ACTIVATE: {
704 int index;
705
706 if (objc != 3) {
707 Tcl_WrongNumArgs(interp, 1, objv, "activate index");
708 goto error;
709 }
710 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index)
711 != TCL_OK) {
712 goto error;
713 }
714 if (menuPtr->active == index) {
715 goto done;
716 }
717 if ((index >= 0)
718 && ((menuPtr->entries[index]->type == SEPARATOR_ENTRY)
719 || (menuPtr->entries[index]->state
720 == ENTRY_DISABLED))) {
721 index = -1;
722 }
723 result = TkActivateMenuEntry(menuPtr, index);
724 break;
725 }
726 case MENU_ADD:
727 if (objc < 3) {
728 Tcl_WrongNumArgs(interp, 1, objv, "add type ?options?");
729 goto error;
730 }
731
732 if (MenuAddOrInsert(interp, menuPtr, (Tcl_Obj *) NULL,
733 objc - 2, objv + 2) != TCL_OK) {
734 goto error;
735 }
736 break;
737 case MENU_CGET: {
738 Tcl_Obj *resultPtr;
739
740 if (objc != 3) {
741 Tcl_WrongNumArgs(interp, 1, objv, "cget option");
742 goto error;
743 }
744 resultPtr = Tk_GetOptionValue(interp, (char *) menuPtr,
745 menuPtr->optionTablesPtr->menuOptionTable, objv[2],
746 menuPtr->tkwin);
747 if (resultPtr == NULL) {
748 goto error;
749 }
750 Tcl_SetObjResult(interp, resultPtr);
751 break;
752 }
753 case MENU_CLONE:
754 if ((objc < 3) || (objc > 4)) {
755 Tcl_WrongNumArgs(interp, 1, objv,
756 "clone newMenuName ?menuType?");
757 goto error;
758 }
759 result = CloneMenu(menuPtr, objv[2], (objc == 3) ? NULL : objv[3]);
760 break;
761 case MENU_CONFIGURE: {
762 Tcl_Obj *resultPtr;
763
764 if (objc == 2) {
765 resultPtr = Tk_GetOptionInfo(interp, (char *) menuPtr,
766 menuPtr->optionTablesPtr->menuOptionTable,
767 (Tcl_Obj *) NULL, menuPtr->tkwin);
768 if (resultPtr == NULL) {
769 result = TCL_ERROR;
770 } else {
771 result = TCL_OK;
772 Tcl_SetObjResult(interp, resultPtr);
773 }
774 } else if (objc == 3) {
775 resultPtr = Tk_GetOptionInfo(interp, (char *) menuPtr,
776 menuPtr->optionTablesPtr->menuOptionTable,
777 objv[2], menuPtr->tkwin);
778 if (resultPtr == NULL) {
779 result = TCL_ERROR;
780 } else {
781 result = TCL_OK;
782 Tcl_SetObjResult(interp, resultPtr);
783 }
784 } else {
785 result = ConfigureMenu(interp, menuPtr, objc - 2, objv + 2);
786 }
787 if (result != TCL_OK) {
788 goto error;
789 }
790 break;
791 }
792 case MENU_DELETE: {
793 int first, last;
794
795 if ((objc != 3) && (objc != 4)) {
796 Tcl_WrongNumArgs(interp, 1, objv, "delete first ?last?");
797 goto error;
798 }
799 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &first)
800 != TCL_OK) {
801 goto error;
802 }
803 if (objc == 3) {
804 last = first;
805 } else {
806 if (TkGetMenuIndex(interp, menuPtr, objv[3], 0, &last)
807 != TCL_OK) {
808 goto error;
809 }
810 }
811 if (menuPtr->tearoff && (first == 0)) {
812
813 /*
814 * Sorry, can't delete the tearoff entry; must reconfigure
815 * the menu.
816 */
817
818 first = 1;
819 }
820 if ((first < 0) || (last < first)) {
821 goto done;
822 }
823 DeleteMenuCloneEntries(menuPtr, first, last);
824 break;
825 }
826 case MENU_ENTRYCGET: {
827 int index;
828 Tcl_Obj *resultPtr;
829
830 if (objc != 4) {
831 Tcl_WrongNumArgs(interp, 1, objv, "entrycget index option");
832 goto error;
833 }
834 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index)
835 != TCL_OK) {
836 goto error;
837 }
838 if (index < 0) {
839 goto done;
840 }
841 mePtr = menuPtr->entries[index];
842 Tcl_Preserve((ClientData) mePtr);
843 resultPtr = Tk_GetOptionValue(interp, (char *) mePtr,
844 mePtr->optionTable, objv[3], menuPtr->tkwin);
845 Tcl_Release((ClientData) mePtr);
846 if (resultPtr == NULL) {
847 goto error;
848 }
849 Tcl_SetObjResult(interp, resultPtr);
850 break;
851 }
852 case MENU_ENTRYCONFIGURE: {
853 int index;
854 Tcl_Obj *resultPtr;
855
856 if (objc < 3) {
857 Tcl_WrongNumArgs(interp, 1, objv,
858 "entryconfigure index ?option value ...?");
859 goto error;
860 }
861 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index)
862 != TCL_OK) {
863 goto error;
864 }
865 if (index < 0) {
866 goto done;
867 }
868 mePtr = menuPtr->entries[index];
869 Tcl_Preserve((ClientData) mePtr);
870 if (objc == 3) {
871 resultPtr = Tk_GetOptionInfo(interp, (char *) mePtr,
872 mePtr->optionTable, (Tcl_Obj *) NULL, menuPtr->tkwin);
873 if (resultPtr == NULL) {
874 result = TCL_ERROR;
875 } else {
876 result = TCL_OK;
877 Tcl_SetObjResult(interp, resultPtr);
878 }
879 } else if (objc == 4) {
880 resultPtr = Tk_GetOptionInfo(interp, (char *) mePtr,
881 mePtr->optionTable, objv[3], menuPtr->tkwin);
882 if (resultPtr == NULL) {
883 result = TCL_ERROR;
884 } else {
885 result = TCL_OK;
886 Tcl_SetObjResult(interp, resultPtr);
887 }
888 } else {
889 result = ConfigureMenuCloneEntries(interp, menuPtr, index,
890 objc - 3, objv + 3);
891 }
892 Tcl_Release((ClientData) mePtr);
893 break;
894 }
895 case MENU_INDEX: {
896 int index;
897
898 if (objc != 3) {
899 Tcl_WrongNumArgs(interp, 1, objv, "index string");
900 goto error;
901 }
902 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index)
903 != TCL_OK) {
904 goto error;
905 }
906 if (index < 0) {
907 Tcl_SetResult(interp, "none", TCL_STATIC);
908 } else {
909 Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
910 }
911 break;
912 }
913 case MENU_INSERT:
914 if (objc < 4) {
915 Tcl_WrongNumArgs(interp, 1, objv,
916 "insert index type ?options?");
917 goto error;
918 }
919 if (MenuAddOrInsert(interp, menuPtr, objv[2], objc - 3,
920 objv + 3) != TCL_OK) {
921 goto error;
922 }
923 break;
924 case MENU_INVOKE: {
925 int index;
926
927 if (objc != 3) {
928 Tcl_WrongNumArgs(interp, 1, objv, "invoke index");
929 goto error;
930 }
931 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index)
932 != TCL_OK) {
933 goto error;
934 }
935 if (index < 0) {
936 goto done;
937 }
938 result = TkInvokeMenu(interp, menuPtr, index);
939 break;
940 }
941 case MENU_POST: {
942 int x, y;
943
944 if (objc != 4) {
945 Tcl_WrongNumArgs(interp, 1, objv, "post x y");
946 goto error;
947 }
948 if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK)
949 || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) {
950 goto error;
951 }
952
953 /*
954 * Tearoff menus are posted differently on Mac and Windows than
955 * non-tearoffs. TkpPostMenu does not actually map the menu's
956 * window on those platforms, and popup menus have to be
957 * handled specially.
958 */
959
960 if (menuPtr->menuType != TEAROFF_MENU) {
961 result = TkpPostMenu(interp, menuPtr, x, y);
962 } else {
963 result = TkPostTearoffMenu(interp, menuPtr, x, y);
964 }
965 break;
966 }
967 case MENU_POSTCASCADE: {
968 int index;
969
970 if (objc != 3) {
971 Tcl_WrongNumArgs(interp, 1, objv, "postcascade index");
972 goto error;
973 }
974
975 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index)
976 != TCL_OK) {
977 goto error;
978 }
979 if ((index < 0) || (menuPtr->entries[index]->type
980 != CASCADE_ENTRY)) {
981 result = TkPostSubmenu(interp, menuPtr, (TkMenuEntry *) NULL);
982 } else {
983 result = TkPostSubmenu(interp, menuPtr,
984 menuPtr->entries[index]);
985 }
986 break;
987 }
988 case MENU_TYPE: {
989 int index;
990
991 if (objc != 3) {
992 Tcl_WrongNumArgs(interp, 1, objv, "type index");
993 goto error;
994 }
995 if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index)
996 != TCL_OK) {
997 goto error;
998 }
999 if (index < 0) {
1000 goto done;
1001 }
1002 if (menuPtr->entries[index]->type == TEAROFF_ENTRY) {
1003 Tcl_SetResult(interp, "tearoff", TCL_STATIC);
1004 } else {
1005 Tcl_SetResult(interp,
1006 menuEntryTypeStrings[menuPtr->entries[index]->type],
1007 TCL_STATIC);
1008 }
1009 break;
1010 }
1011 case MENU_UNPOST:
1012 if (objc != 2) {
1013 Tcl_WrongNumArgs(interp, 1, objv, "unpost");
1014 goto error;
1015 }
1016 Tk_UnmapWindow(menuPtr->tkwin);
1017 result = TkPostSubmenu(interp, menuPtr, (TkMenuEntry *) NULL);
1018 break;
1019 case MENU_YPOSITION:
1020 if (objc != 3) {
1021 Tcl_WrongNumArgs(interp, 1, objv, "yposition index");
1022 goto error;
1023 }
1024 result = MenuDoYPosition(interp, menuPtr, objv[2]);
1025 break;
1026 }
1027 done:
1028 Tcl_Release((ClientData) menuPtr);
1029 return result;
1030
1031 error:
1032 Tcl_Release((ClientData) menuPtr);
1033 return TCL_ERROR;
1034 }
1035
1036 /*
1037 *----------------------------------------------------------------------
1038 *
1039 * TkInvokeMenu --
1040 *
1041 * Given a menu and an index, takes the appropriate action for the
1042 * entry associated with that index.
1043 *
1044 * Results:
1045 * Standard Tcl result.
1046 *
1047 * Side effects:
1048 * Commands may get excecuted; variables may get set; sub-menus may
1049 * get posted.
1050 *
1051 *----------------------------------------------------------------------
1052 */
1053
1054 int
1055 TkInvokeMenu(interp, menuPtr, index)
1056 Tcl_Interp *interp; /* The interp that the menu lives in. */
1057 TkMenu *menuPtr; /* The menu we are invoking. */
1058 int index; /* The zero based index of the item we
1059 * are invoking */
1060 {
1061 int result = TCL_OK;
1062 TkMenuEntry *mePtr;
1063
1064 if (index < 0) {
1065 goto done;
1066 }
1067 mePtr = menuPtr->entries[index];
1068 if (mePtr->state == ENTRY_DISABLED) {
1069 goto done;
1070 }
1071 Tcl_Preserve((ClientData) mePtr);
1072 if (mePtr->type == TEAROFF_ENTRY) {
1073 Tcl_DString ds;
1074 Tcl_DStringInit(&ds);
1075 Tcl_DStringAppend(&ds, "tkTearOffMenu ", -1);
1076 Tcl_DStringAppend(&ds, Tk_PathName(menuPtr->tkwin), -1);
1077 result = Tcl_Eval(interp, Tcl_DStringValue(&ds));
1078 Tcl_DStringFree(&ds);
1079 } else if ((mePtr->type == CHECK_BUTTON_ENTRY)
1080 && (mePtr->namePtr != NULL)) {
1081 Tcl_Obj *valuePtr;
1082
1083 if (mePtr->entryFlags & ENTRY_SELECTED) {
1084 valuePtr = mePtr->offValuePtr;
1085 } else {
1086 valuePtr = mePtr->onValuePtr;
1087 }
1088 if (valuePtr == NULL) {
1089 valuePtr = Tcl_NewObj();
1090 }
1091 Tcl_IncrRefCount(valuePtr);
1092 if (Tcl_ObjSetVar2(interp, mePtr->namePtr, NULL, valuePtr,
1093 TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
1094 result = TCL_ERROR;
1095 }
1096 Tcl_DecrRefCount(valuePtr);
1097 } else if ((mePtr->type == RADIO_BUTTON_ENTRY)
1098 && (mePtr->namePtr != NULL)) {
1099 Tcl_Obj *valuePtr = mePtr->onValuePtr;
1100
1101 if (valuePtr == NULL) {
1102 valuePtr = Tcl_NewObj();
1103 }
1104 Tcl_IncrRefCount(valuePtr);
1105 if (Tcl_ObjSetVar2(interp, mePtr->namePtr, NULL, valuePtr,
1106 TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
1107 result = TCL_ERROR;
1108 }
1109 Tcl_DecrRefCount(valuePtr);
1110 }
1111 if ((result == TCL_OK) && (mePtr->commandPtr != NULL)) {
1112 Tcl_Obj *commandPtr = mePtr->commandPtr;
1113
1114 Tcl_IncrRefCount(commandPtr);
1115 result = Tcl_EvalObjEx(interp, commandPtr, TCL_EVAL_GLOBAL);
1116 Tcl_DecrRefCount(commandPtr);
1117 }
1118 Tcl_Release((ClientData) mePtr);
1119 done:
1120 return result;
1121 }
1122
1123 /*
1124 *----------------------------------------------------------------------
1125 *
1126 * DestroyMenuInstance --
1127 *
1128 * This procedure is invoked by TkDestroyMenu
1129 * to clean up the internal structure of a menu at a safe time
1130 * (when no-one is using it anymore). Only takes care of one instance
1131 * of the menu.
1132 *
1133 * Results:
1134 * None.
1135 *
1136 * Side effects:
1137 * Everything associated with the menu is freed up.
1138 *
1139 *----------------------------------------------------------------------
1140 */
1141
1142 static void
1143 DestroyMenuInstance(menuPtr)
1144 TkMenu *menuPtr; /* Info about menu widget. */
1145 {
1146 int i;
1147 TkMenu *menuInstancePtr;
1148 TkMenuEntry *cascadePtr, *nextCascadePtr;
1149 Tcl_Obj *newObjv[2];
1150 TkMenu *parentMasterMenuPtr;
1151 TkMenuEntry *parentMasterEntryPtr;
1152
1153 /*
1154 * If the menu has any cascade menu entries pointing to it, the cascade
1155 * entries need to be told that the menu is going away. We need to clear
1156 * the menu ptr field in the menu reference at this point in the code
1157 * so that everything else can forget about this menu properly. We also
1158 * need to reset -menu field of all entries that are not master menus
1159 * back to this entry name if this is a master menu pointed to by another
1160 * master menu. If there is a clone menu that points to this menu,
1161 * then this menu is itself a clone, so when this menu goes away,
1162 * the -menu field of the pointing entry must be set back to this
1163 * menu's master menu name so that later if another menu is created
1164 * the cascade hierarchy can be maintained.
1165 */
1166
1167 TkpDestroyMenu(menuPtr);
1168 cascadePtr = menuPtr->menuRefPtr->parentEntryPtr;
1169 menuPtr->menuRefPtr->menuPtr = NULL;
1170 TkFreeMenuReferences(menuPtr->menuRefPtr);
1171
1172 for (; cascadePtr != NULL; cascadePtr = nextCascadePtr) {
1173 nextCascadePtr = cascadePtr->nextCascadePtr;
1174
1175 if (menuPtr->masterMenuPtr != menuPtr) {
1176 Tcl_Obj *menuNamePtr = Tcl_NewStringObj("-menu", -1);
1177
1178 parentMasterMenuPtr = cascadePtr->menuPtr->masterMenuPtr;
1179 parentMasterEntryPtr =
1180 parentMasterMenuPtr->entries[cascadePtr->index];
1181 newObjv[0] = menuNamePtr;
1182 newObjv[1] = parentMasterEntryPtr->namePtr;
1183 /*
1184 * It is possible that the menu info is out of sync, and
1185 * these things point to NULL, so verify existence [Bug: 3402]
1186 */
1187 if (newObjv[0] && newObjv[1]) {
1188 Tcl_IncrRefCount(newObjv[0]);
1189 Tcl_IncrRefCount(newObjv[1]);
1190 ConfigureMenuEntry(cascadePtr, 2, newObjv);
1191 Tcl_DecrRefCount(newObjv[0]);
1192 Tcl_DecrRefCount(newObjv[1]);
1193 }
1194 } else {
1195 ConfigureMenuEntry(cascadePtr, 0, (Tcl_Obj **) NULL);
1196 }
1197 }
1198
1199 if (menuPtr->masterMenuPtr != menuPtr) {
1200 for (menuInstancePtr = menuPtr->masterMenuPtr;
1201 menuInstancePtr != NULL;
1202 menuInstancePtr = menuInstancePtr->nextInstancePtr) {
1203 if (menuInstancePtr->nextInstancePtr == menuPtr) {
1204 menuInstancePtr->nextInstancePtr =
1205 menuInstancePtr->nextInstancePtr->nextInstancePtr;
1206 break;
1207 }
1208 }
1209 } else if (menuPtr->nextInstancePtr != NULL) {
1210 panic("Attempting to delete master menu when there are still clones.");
1211 }
1212
1213 /*
1214 * Free up all the stuff that requires special handling, then
1215 * let Tk_FreeConfigOptions handle all the standard option-related
1216 * stuff.
1217 */
1218
1219 for (i = menuPtr->numEntries; --i >= 0; ) {
1220 /*
1221 * As each menu entry is deleted from the end of the array of
1222 * entries, decrement menuPtr->numEntries. Otherwise, the act of
1223 * deleting menu entry i will dereference freed memory attempting
1224 * to queue a redraw for menu entries (i+1)...numEntries.
1225 */
1226
1227 DestroyMenuEntry((char *) menuPtr->entries[i]);
1228 menuPtr->numEntries = i;
1229 }
1230 if (menuPtr->entries != NULL) {
1231 ckfree((char *) menuPtr->entries);
1232 }
1233 TkMenuFreeDrawOptions(menuPtr);
1234 Tk_FreeConfigOptions((char *) menuPtr,
1235 menuPtr->optionTablesPtr->menuOptionTable, menuPtr->tkwin);
1236 }
1237
1238 /*
1239 *----------------------------------------------------------------------
1240 *
1241 * TkDestroyMenu --
1242 *
1243 * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release
1244 * to clean up the internal structure of a menu at a safe time
1245 * (when no-one is using it anymore). If called on a master instance,
1246 * destroys all of the slave instances. If called on a non-master
1247 * instance, just destroys that instance.
1248 *
1249 * Results:
1250 * None.
1251 *
1252 * Side effects:
1253 * Everything associated with the menu is freed up.
1254 *
1255 *----------------------------------------------------------------------
1256 */
1257
1258 void
1259 TkDestroyMenu(menuPtr)
1260 TkMenu *menuPtr; /* Info about menu widget. */
1261 {
1262 TkMenu *menuInstancePtr;
1263 TkMenuTopLevelList *topLevelListPtr, *nextTopLevelPtr;
1264
1265 if (menuPtr->menuFlags & MENU_DELETION_PENDING) {
1266 return;
1267 }
1268
1269 /*
1270 * Now destroy all non-tearoff instances of this menu if this is a
1271 * parent menu. Is this loop safe enough? Are there going to be
1272 * destroy bindings on child menus which kill the parent? If not,
1273 * we have to do a slightly more complex scheme.
1274 */
1275
1276 if (menuPtr->masterMenuPtr == menuPtr) {
1277 menuPtr->menuFlags |= MENU_DELETION_PENDING;
1278 while (menuPtr->nextInstancePtr != NULL) {
1279 menuInstancePtr = menuPtr->nextInstancePtr;
1280 menuPtr->nextInstancePtr = menuInstancePtr->nextInstancePtr;
1281 if (menuInstancePtr->tkwin != NULL) {
1282 Tk_DestroyWindow(menuInstancePtr->tkwin);
1283 }
1284 }
1285 menuPtr->menuFlags &= ~MENU_DELETION_PENDING;
1286 }
1287
1288 /*
1289 * If any toplevel widgets have this menu as their menubar,
1290 * the geometry of the window may have to be recalculated.
1291 */
1292
1293 topLevelListPtr = menuPtr->menuRefPtr->topLevelListPtr;
1294 while (topLevelListPtr != NULL) {
1295 nextTopLevelPtr = topLevelListPtr->nextPtr;
1296 TkpSetWindowMenuBar(topLevelListPtr->tkwin, NULL);
1297 topLevelListPtr = nextTopLevelPtr;
1298 }
1299 DestroyMenuInstance(menuPtr);
1300 }
1301
1302 /*
1303 *----------------------------------------------------------------------
1304 *
1305 * UnhookCascadeEntry --
1306 *
1307 * This entry is removed from the list of entries that point to the
1308 * cascade menu. This is done in preparation for changing the menu
1309 * that this entry points to.
1310 *
1311 * Results:
1312 * None
1313 *
1314 * Side effects:
1315 * The appropriate lists are modified.
1316 *
1317 *----------------------------------------------------------------------
1318 */
1319
1320 static void
1321 UnhookCascadeEntry(mePtr)
1322 TkMenuEntry *mePtr; /* The cascade entry we are removing
1323 * from the cascade list. */
1324 {
1325 TkMenuEntry *cascadeEntryPtr;
1326 TkMenuEntry *prevCascadePtr;
1327 TkMenuReferences *menuRefPtr;
1328
1329 menuRefPtr = mePtr->childMenuRefPtr;
1330 if (menuRefPtr == NULL) {
1331 return;
1332 }
1333
1334 cascadeEntryPtr = menuRefPtr->parentEntryPtr;
1335 if (cascadeEntryPtr == NULL) {
1336 return;
1337 }
1338
1339 /*
1340 * Singularly linked list deletion. The two special cases are
1341 * 1. one element; 2. The first element is the one we want.
1342 */
1343
1344 if (cascadeEntryPtr == mePtr) {
1345 if (cascadeEntryPtr->nextCascadePtr == NULL) {
1346
1347 /*
1348 * This is the last menu entry which points to this
1349 * menu, so we need to clear out the list pointer in the
1350 * cascade itself.
1351 */
1352
1353 menuRefPtr->parentEntryPtr = NULL;
1354 TkFreeMenuReferences(menuRefPtr);
1355 } else {
1356 menuRefPtr->parentEntryPtr = cascadeEntryPtr->nextCascadePtr;
1357 }
1358 mePtr->nextCascadePtr = NULL;
1359 } else {
1360 for (prevCascadePtr = cascadeEntryPtr,
1361 cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr;
1362 cascadeEntryPtr != NULL;
1363 prevCascadePtr = cascadeEntryPtr,
1364 cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) {
1365 if (cascadeEntryPtr == mePtr){
1366 prevCascadePtr->nextCascadePtr =
1367 cascadeEntryPtr->nextCascadePtr;
1368 cascadeEntryPtr->nextCascadePtr = NULL;
1369 break;
1370 }
1371 }
1372 }
1373 mePtr->childMenuRefPtr = NULL;
1374 }
1375
1376 /*
1377 *----------------------------------------------------------------------
1378 *
1379 * DestroyMenuEntry --
1380 *
1381 * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release
1382 * to clean up the internal structure of a menu entry at a safe time
1383 * (when no-one is using it anymore).
1384 *
1385 * Results:
1386 * None.
1387 *
1388 * Side effects:
1389 * Everything associated with the menu entry is freed.
1390 *
1391 *----------------------------------------------------------------------
1392 */
1393
1394 static void
1395 DestroyMenuEntry(memPtr)
1396 char *memPtr; /* Pointer to entry to be freed. */
1397 {
1398 register TkMenuEntry *mePtr = (TkMenuEntry *) memPtr;
1399 TkMenu *menuPtr = mePtr->menuPtr;
1400
1401 if (menuPtr->postedCascade == mePtr) {
1402
1403 /*
1404 * Ignore errors while unposting the menu, since it's possible
1405 * that the menu has already been deleted and the unpost will
1406 * generate an error.
1407 */
1408
1409 TkPostSubmenu(menuPtr->interp, menuPtr, (TkMenuEntry *) NULL);
1410 }
1411
1412 /*
1413 * Free up all the stuff that requires special handling, then
1414 * let Tk_FreeConfigOptions handle all the standard option-related
1415 * stuff.
1416 */
1417
1418 if (mePtr->type == CASCADE_ENTRY) {
1419 UnhookCascadeEntry(mePtr);
1420 }
1421 if (mePtr->image != NULL) {
1422 Tk_FreeImage(mePtr->image);
1423 }
1424 if (mePtr->selectImage != NULL) {
1425 Tk_FreeImage(mePtr->selectImage);
1426 }
1427 if (((mePtr->type == CHECK_BUTTON_ENTRY)
1428 || (mePtr->type == RADIO_BUTTON_ENTRY))
1429 && (mePtr->namePtr != NULL)) {
1430 char *varName = Tcl_GetStringFromObj(mePtr->namePtr, NULL);
1431 Tcl_UntraceVar(menuPtr->interp, varName,
1432 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
1433 MenuVarProc, (ClientData) mePtr);
1434 }
1435 TkpDestroyMenuEntry(mePtr);
1436 TkMenuEntryFreeDrawOptions(mePtr);
1437 Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable, menuPtr->tkwin);
1438 ckfree((char *) mePtr);
1439 }
1440
1441 /*
1442 *---------------------------------------------------------------------------
1443 *
1444 * MenuWorldChanged --
1445 *
1446 * This procedure is called when the world has changed in some
1447 * way (such as the fonts in the system changing) and the widget needs
1448 * to recompute all its graphics contexts and determine its new geometry.
1449 *
1450 * Results:
1451 * None.
1452 *
1453 * Side effects:
1454 * Menu will be relayed out and redisplayed.
1455 *
1456 *---------------------------------------------------------------------------
1457 */
1458
1459 static void
1460 MenuWorldChanged(instanceData)
1461 ClientData instanceData; /* Information about widget. */
1462 {
1463 TkMenu *menuPtr = (TkMenu *) instanceData;
1464 int i;
1465
1466 TkMenuConfigureDrawOptions(menuPtr);
1467 for (i = 0; i < menuPtr->numEntries; i++) {
1468 TkMenuConfigureEntryDrawOptions(menuPtr->entries[i],
1469 menuPtr->entries[i]->index);
1470 TkpConfigureMenuEntry(menuPtr->entries[i]);
1471 }
1472 }
1473
1474 /*
1475 *----------------------------------------------------------------------
1476 *
1477 * ConfigureMenu --
1478 *
1479 * This procedure is called to process an argv/argc list, plus
1480 * the Tk option database, in order to configure (or
1481 * reconfigure) a menu widget.
1482 *
1483 * Results:
1484 * The return value is a standard Tcl result. If TCL_ERROR is
1485 * returned, then the interp's result contains an error message.
1486 *
1487 * Side effects:
1488 * Configuration information, such as colors, font, etc. get set
1489 * for menuPtr; old resources get freed, if there were any.
1490 *
1491 *----------------------------------------------------------------------
1492 */
1493
1494 static int
1495 ConfigureMenu(interp, menuPtr, objc, objv)
1496 Tcl_Interp *interp; /* Used for error reporting. */
1497 register TkMenu *menuPtr; /* Information about widget; may or may
1498 * not already have values for some fields. */
1499 int objc; /* Number of valid entries in argv. */
1500 Tcl_Obj *CONST objv[]; /* Arguments. */
1501 {
1502 int i;
1503 TkMenu *menuListPtr, *cleanupPtr;
1504 int result;
1505
1506 for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL;
1507 menuListPtr = menuListPtr->nextInstancePtr) {
1508 menuListPtr->errorStructPtr = (Tk_SavedOptions *)
1509 ckalloc(sizeof(Tk_SavedOptions));
1510 result = Tk_SetOptions(interp, (char *) menuListPtr,
1511 menuListPtr->optionTablesPtr->menuOptionTable, objc, objv,
1512 menuListPtr->tkwin, menuListPtr->errorStructPtr, (int *) NULL);
1513 if (result != TCL_OK) {
1514 for (cleanupPtr = menuPtr->masterMenuPtr;
1515 cleanupPtr != menuListPtr;
1516 cleanupPtr = cleanupPtr->nextInstancePtr) {
1517 Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr);
1518 ckfree((char *) cleanupPtr->errorStructPtr);
1519 cleanupPtr->errorStructPtr = NULL;
1520 }
1521 return TCL_ERROR;
1522 }
1523
1524 /*
1525 * When a menu is created, the type is in all of the arguments
1526 * to the menu command. Let Tk_ConfigureWidget take care of
1527 * parsing them, and then set the type after we can look at
1528 * the type string. Once set, a menu's type cannot be changed
1529 */
1530
1531 if (menuListPtr->menuType == UNKNOWN_TYPE) {
1532 Tcl_GetIndexFromObj(NULL, menuListPtr->menuTypePtr,
1533 menuTypeStrings, NULL, 0, &menuListPtr->menuType);
1534
1535 /*
1536 * Configure the new window to be either a pop-up menu
1537 * or a tear-off menu.
1538 * We don't do this for menubars since they are not toplevel
1539 * windows. Also, since this gets called before CloneMenu has
1540 * a chance to set the menuType field, we have to look at the
1541 * menuTypeName field to tell that this is a menu bar.
1542 */
1543
1544 if (menuListPtr->menuType == MASTER_MENU) {
1545 TkpMakeMenuWindow(menuListPtr->tkwin, 1);
1546 } else if (menuListPtr->menuType == TEAROFF_MENU) {
1547 TkpMakeMenuWindow(menuListPtr->tkwin, 0);
1548 }
1549 }
1550
1551
1552 /*
1553 * Depending on the -tearOff option, make sure that there is or
1554 * isn't an initial tear-off entry at the beginning of the menu.
1555 */
1556
1557 if (menuListPtr->tearoff) {
1558 if ((menuListPtr->numEntries == 0)
1559 || (menuListPtr->entries[0]->type != TEAROFF_ENTRY)) {
1560 if (MenuNewEntry(menuListPtr, 0, TEAROFF_ENTRY) == NULL) {
1561 if (menuListPtr->errorStructPtr != NULL) {
1562 for (cleanupPtr = menuPtr->masterMenuPtr;
1563 cleanupPtr != menuListPtr;
1564 cleanupPtr = cleanupPtr->nextInstancePtr) {
1565 Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr);
1566 ckfree((char *) cleanupPtr->errorStructPtr);
1567 cleanupPtr->errorStructPtr = NULL;
1568 }
1569 Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr);
1570 ckfree((char *) cleanupPtr->errorStructPtr);
1571 cleanupPtr->errorStructPtr = NULL;
1572 }
1573 return TCL_ERROR;
1574 }
1575 }
1576 } else if ((menuListPtr->numEntries > 0)
1577 && (menuListPtr->entries[0]->type == TEAROFF_ENTRY)) {
1578 int i;
1579
1580 Tcl_EventuallyFree((ClientData) menuListPtr->entries[0],
1581 DestroyMenuEntry);
1582
1583 for (i = 0; i < menuListPtr->numEntries - 1; i++) {
1584 menuListPtr->entries[i] = menuListPtr->entries[i + 1];
1585 menuListPtr->entries[i]->index = i;
1586 }
1587 menuListPtr->numEntries--;
1588 if (menuListPtr->numEntries == 0) {
1589 ckfree((char *) menuListPtr->entries);
1590 menuListPtr->entries = NULL;
1591 }
1592 }
1593
1594 TkMenuConfigureDrawOptions(menuListPtr);
1595
1596 /*
1597 * After reconfiguring a menu, we need to reconfigure all of the
1598 * entries in the menu, since some of the things in the children
1599 * (such as graphics contexts) may have to change to reflect changes
1600 * in the parent.
1601 */
1602
1603 for (i = 0; i < menuListPtr->numEntries; i++) {
1604 TkMenuEntry *mePtr;
1605
1606 mePtr = menuListPtr->entries[i];
1607 ConfigureMenuEntry(mePtr, 0, (Tcl_Obj **) NULL);
1608 }
1609
1610 TkEventuallyRecomputeMenu(menuListPtr);
1611 }
1612
1613 for (cleanupPtr = menuPtr->masterMenuPtr; cleanupPtr != NULL;
1614 cleanupPtr = cleanupPtr->nextInstancePtr) {
1615 Tk_FreeSavedOptions(cleanupPtr->errorStructPtr);
1616 ckfree((char *) cleanupPtr->errorStructPtr);
1617 cleanupPtr->errorStructPtr = NULL;
1618 }
1619
1620 return TCL_OK;
1621 }
1622
1623
1624 /*
1625 *----------------------------------------------------------------------
1626 *
1627 * PostProcessEntry --
1628 *
1629 * This is called by ConfigureMenuEntry to do all of the configuration
1630 * after Tk_SetOptions is called. This is separate
1631 * so that error handling is easier.
1632 *
1633 * Results:
1634 * The return value is a standard Tcl result. If TCL_ERROR is
1635 * returned, then the interp's result contains an error message.
1636 *
1637 * Side effects:
1638 * Configuration information such as label and accelerator get
1639 * set for mePtr; old resources get freed, if there were any.
1640 *
1641 *----------------------------------------------------------------------
1642 */
1643
1644 static int
1645 PostProcessEntry(mePtr)
1646 TkMenuEntry *mePtr; /* The entry we are configuring. */
1647 {
1648 TkMenu *menuPtr = mePtr->menuPtr;
1649 int index = mePtr->index;
1650 char *name;
1651 Tk_Image image;
1652
1653 /*
1654 * The code below handles special configuration stuff not taken
1655 * care of by Tk_ConfigureWidget, such as special processing for
1656 * defaults, sizing strings, graphics contexts, etc.
1657 */
1658
1659 if (mePtr->labelPtr == NULL) {
1660 mePtr->labelLength = 0;
1661 } else {
1662 Tcl_GetStringFromObj(mePtr->labelPtr, &mePtr->labelLength);
1663 }
1664 if (mePtr->accelPtr == NULL) {
1665 mePtr->accelLength = 0;
1666 } else {
1667 Tcl_GetStringFromObj(mePtr->accelPtr, &mePtr->accelLength);
1668 }
1669
1670 /*
1671 * If this is a cascade entry, the platform-specific data of the child
1672 * menu has to be updated. Also, the links that point to parents and
1673 * cascades have to be updated.
1674 */
1675
1676 if ((mePtr->type == CASCADE_ENTRY) && (mePtr->namePtr != NULL)) {
1677 TkMenuEntry *cascadeEntryPtr;
1678 int alreadyThere;
1679 TkMenuReferences *menuRefPtr;
1680 char *oldHashKey = NULL; /* Initialization only needed to
1681 * prevent compiler warning. */
1682
1683 /*
1684 * This is a cascade entry. If the menu that the cascade entry
1685 * is pointing to has changed, we need to remove this entry
1686 * from the list of entries pointing to the old menu, and add a
1687 * cascade reference to the list of entries pointing to the
1688 * new menu.
1689 *
1690 * BUG: We are not recloning for special case #3 yet.
1691 */
1692
1693 name = Tcl_GetStringFromObj(mePtr->namePtr, NULL);
1694 if (mePtr->childMenuRefPtr != NULL) {
1695 oldHashKey = Tcl_GetHashKey(TkGetMenuHashTable(menuPtr->interp),
1696 mePtr->childMenuRefPtr->hashEntryPtr);
1697 if (strcmp(oldHashKey, name) != 0) {
1698 UnhookCascadeEntry(mePtr);
1699 }
1700 }
1701
1702 if ((mePtr->childMenuRefPtr == NULL)
1703 || (strcmp(oldHashKey, name) != 0)) {
1704 menuRefPtr = TkCreateMenuReferences(menuPtr->interp, name);
1705 mePtr->childMenuRefPtr = menuRefPtr;
1706
1707 if (menuRefPtr->parentEntryPtr == NULL) {
1708 menuRefPtr->parentEntryPtr = mePtr;
1709 } else {
1710 alreadyThere = 0;
1711 for (cascadeEntryPtr = menuRefPtr->parentEntryPtr;
1712 cascadeEntryPtr != NULL;
1713 cascadeEntryPtr =
1714 cascadeEntryPtr->nextCascadePtr) {
1715 if (cascadeEntryPtr == mePtr) {
1716 alreadyThere = 1;
1717 break;
1718 }
1719 }
1720
1721 /*
1722 * Put the item at the front of the list.
1723 */
1724
1725 if (!alreadyThere) {
1726 mePtr->nextCascadePtr = menuRefPtr->parentEntryPtr;
1727 menuRefPtr->parentEntryPtr = mePtr;
1728 }
1729 }
1730 }
1731 }
1732
1733 if (TkMenuConfigureEntryDrawOptions(mePtr, index) != TCL_OK) {
1734 return TCL_ERROR;
1735 }
1736
1737 if (TkpConfigureMenuEntry(mePtr) != TCL_OK) {
1738 return TCL_ERROR;
1739 }
1740
1741 /*
1742 * Get the images for the entry, if there are any. Allocate the
1743 * new images before freeing the old ones, so that the reference
1744 * counts don't go to zero and cause image data to be discarded.
1745 */
1746
1747 if (mePtr->imagePtr != NULL) {
1748 char *imageString = Tcl_GetStringFromObj(mePtr->imagePtr, NULL);
1749 image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, imageString,
1750 TkMenuImageProc, (ClientData) mePtr);
1751 if (image == NULL) {
1752 return TCL_ERROR;
1753 }
1754 } else {
1755 image = NULL;
1756 }
1757 if (mePtr->image != NULL) {
1758 Tk_FreeImage(mePtr->image);
1759 }
1760 mePtr->image = image;
1761 if (mePtr->selectImagePtr != NULL) {
1762 char *selectImageString = Tcl_GetStringFromObj(
1763 mePtr->selectImagePtr, NULL);
1764 image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, selectImageString,
1765 TkMenuSelectImageProc, (ClientData) mePtr);
1766 if (image == NULL) {
1767 return TCL_ERROR;
1768 }
1769 } else {
1770 image = NULL;
1771 }
1772 if (mePtr->selectImage != NULL) {
1773 Tk_FreeImage(mePtr->selectImage);
1774 }
1775 mePtr->selectImage = image;
1776
1777 if ((mePtr->type == CHECK_BUTTON_ENTRY)
1778 || (mePtr->type == RADIO_BUTTON_ENTRY)) {
1779 Tcl_Obj *valuePtr;
1780 char *name;
1781
1782 if (mePtr->namePtr == NULL) {
1783 if (mePtr->labelPtr == NULL) {
1784 mePtr->namePtr = NULL;
1785 } else {
1786 mePtr->namePtr = Tcl_DuplicateObj(mePtr->labelPtr);
1787 Tcl_IncrRefCount(mePtr->namePtr);
1788 }
1789 }
1790 if (mePtr->onValuePtr == NULL) {
1791 if (mePtr->labelPtr == NULL) {
1792 mePtr->onValuePtr = NULL;
1793 } else {
1794 mePtr->onValuePtr = Tcl_DuplicateObj(mePtr->labelPtr);
1795 Tcl_IncrRefCount(mePtr->onValuePtr);
1796 }
1797 }
1798
1799 /*
1800 * Select the entry if the associated variable has the
1801 * appropriate value, initialize the variable if it doesn't
1802 * exist, then set a trace on the variable to monitor future
1803 * changes to its value.
1804 */
1805
1806 if (mePtr->namePtr != NULL) {
1807 valuePtr = Tcl_ObjGetVar2(menuPtr->interp, mePtr->namePtr, NULL,
1808 TCL_GLOBAL_ONLY);
1809 } else {
1810 valuePtr = NULL;
1811 }
1812 mePtr->entryFlags &= ~ENTRY_SELECTED;
1813 if (valuePtr != NULL) {
1814 if (mePtr->onValuePtr != NULL) {
1815 char *value = Tcl_GetStringFromObj(valuePtr, NULL);
1816 char *onValue = Tcl_GetStringFromObj(mePtr->onValuePtr,
1817 NULL);
1818
1819
1820 if (strcmp(value, onValue) == 0) {
1821 mePtr->entryFlags |= ENTRY_SELECTED;
1822 }
1823 }
1824 } else {
1825 if (mePtr->namePtr != NULL) {
1826 Tcl_ObjSetVar2(menuPtr->interp, mePtr->namePtr, NULL,
1827 (mePtr->type == CHECK_BUTTON_ENTRY)
1828 ? mePtr->offValuePtr
1829 : Tcl_NewObj(),
1830 TCL_GLOBAL_ONLY);
1831 }
1832 }
1833 if (mePtr->namePtr != NULL) {
1834 name = Tcl_GetStringFromObj(mePtr->namePtr, NULL);
1835 Tcl_TraceVar(menuPtr->interp, name,
1836 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
1837 MenuVarProc, (ClientData) mePtr);
1838 }
1839 }
1840
1841 return TCL_OK;
1842 }
1843
1844 /*
1845 *----------------------------------------------------------------------
1846 *
1847 * ConfigureMenuEntry --
1848 *
1849 * This procedure is called to process an argv/argc list in order
1850 * to configure (or reconfigure) one entry in a menu.
1851 *
1852 * Results:
1853 * The return value is a standard Tcl result. If TCL_ERROR is
1854 * returned, then the interp's result contains an error message.
1855 *
1856 * Side effects:
1857 * Configuration information such as label and accelerator get
1858 * set for mePtr; old resources get freed, if there were any.
1859 *
1860 *----------------------------------------------------------------------
1861 */
1862
1863 static int
1864 ConfigureMenuEntry(mePtr, objc, objv)
1865 register TkMenuEntry *mePtr; /* Information about menu entry; may
1866 * or may not already have values for
1867 * some fields. */
1868 int objc; /* Number of valid entries in argv. */
1869 Tcl_Obj *CONST objv[]; /* Arguments. */
1870 {
1871 TkMenu *menuPtr = mePtr->menuPtr;
1872 Tk_SavedOptions errorStruct;
1873 int result;
1874
1875 /*
1876 * If this entry is a check button or radio button, then remove
1877 * its old trace procedure.
1878 */
1879
1880 if ((mePtr->namePtr != NULL)
1881 && ((mePtr->type == CHECK_BUTTON_ENTRY)
1882 || (mePtr->type == RADIO_BUTTON_ENTRY))) {
1883 char *name = Tcl_GetStringFromObj(mePtr->namePtr, NULL);
1884 Tcl_UntraceVar(menuPtr->interp, name,
1885 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
1886 MenuVarProc, (ClientData) mePtr);
1887 }
1888
1889 result = TCL_OK;
1890 if (menuPtr->tkwin != NULL) {
1891 if (Tk_SetOptions(menuPtr->interp, (char *) mePtr,
1892 mePtr->optionTable, objc, objv, menuPtr->tkwin,
1893 &errorStruct, (int *) NULL) != TCL_OK) {
1894 return TCL_ERROR;
1895 }
1896 result = PostProcessEntry(mePtr);
1897 if (result != TCL_OK) {
1898 Tk_RestoreSavedOptions(&errorStruct);
1899 PostProcessEntry(mePtr);
1900 }
1901 Tk_FreeSavedOptions(&errorStruct);
1902 }
1903
1904 TkEventuallyRecomputeMenu(menuPtr);
1905
1906 return result;
1907 }
1908
1909 /*
1910 *----------------------------------------------------------------------
1911 *
1912 * ConfigureMenuCloneEntries --
1913 *
1914 * Calls ConfigureMenuEntry for each menu in the clone chain.
1915 *
1916 * Results:
1917 * The return value is a standard Tcl result. If TCL_ERROR is
1918 * returned, then the interp's result contains an error message.
1919 *
1920 * Side effects:
1921 * Configuration information such as label and accelerator get
1922 * set for mePtr; old resources get freed, if there were any.
1923 *
1924 *----------------------------------------------------------------------
1925 */
1926
1927 static int
1928 ConfigureMenuCloneEntries(interp, menuPtr, index, objc, objv)
1929 Tcl_Interp *interp; /* Used for error reporting. */
1930 TkMenu *menuPtr; /* Information about whole menu. */
1931 int index; /* Index of mePtr within menuPtr's
1932 * entries. */
1933 int objc; /* Number of valid entries in argv. */
1934 Tcl_Obj *CONST objv[]; /* Arguments. */
1935 {
1936 TkMenuEntry *mePtr;
1937 TkMenu *menuListPtr;
1938 int cascadeEntryChanged = 0;
1939 TkMenuReferences *oldCascadeMenuRefPtr, *cascadeMenuRefPtr = NULL;
1940 Tcl_Obj *oldCascadePtr = NULL;
1941 char *newCascadeName;
1942
1943 /*
1944 * Cascades are kind of tricky here. This is special case #3 in the comment
1945 * at the top of this file. Basically, if a menu is the master menu of a
1946 * clone chain, and has an entry with a cascade menu, the clones of
1947 * the menu will point to clones of the cascade menu. We have
1948 * to destroy the clones of the cascades, clone the new cascade
1949 * menu, and configure the entry to point to the new clone.
1950 */
1951
1952 mePtr = menuPtr->masterMenuPtr->entries[index];
1953 if (mePtr->type == CASCADE_ENTRY) {
1954 oldCascadePtr = mePtr->namePtr;
1955 if (oldCascadePtr != NULL) {
1956 Tcl_IncrRefCount(oldCascadePtr);
1957 }
1958 }
1959
1960 if (ConfigureMenuEntry(mePtr, objc, objv) != TCL_OK) {
1961 return TCL_ERROR;
1962 }
1963
1964 if (mePtr->type == CASCADE_ENTRY) {
1965 char *oldCascadeName;
1966
1967 if (mePtr->namePtr != NULL) {
1968 newCascadeName = Tcl_GetStringFromObj(mePtr->namePtr, NULL);
1969 } else {
1970 newCascadeName = NULL;
1971 }
1972
1973 if ((oldCascadePtr == NULL) && (mePtr->namePtr == NULL)) {
1974 cascadeEntryChanged = 0;
1975 } else if (((oldCascadePtr == NULL) && (mePtr->namePtr != NULL))
1976 || ((oldCascadePtr != NULL)
1977 && (mePtr->namePtr == NULL))) {
1978 cascadeEntryChanged = 1;
1979 } else {
1980 oldCascadeName = Tcl_GetStringFromObj(oldCascadePtr,
1981 NULL);
1982 cascadeEntryChanged = (strcmp(oldCascadeName, newCascadeName)
1983 == 0);
1984 }
1985 if (oldCascadePtr != NULL) {
1986 Tcl_DecrRefCount(oldCascadePtr);
1987 }
1988 }
1989
1990 if (cascadeEntryChanged) {
1991 if (mePtr->namePtr != NULL) {
1992 newCascadeName = Tcl_GetStringFromObj(mePtr->namePtr, NULL);
1993 cascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp,
1994 newCascadeName);
1995 }
1996 }
1997
1998 for (menuListPtr = menuPtr->masterMenuPtr->nextInstancePtr;
1999 menuListPtr != NULL;
2000 menuListPtr = menuListPtr->nextInstancePtr) {
2001
2002 mePtr = menuListPtr->entries[index];
2003
2004 if (cascadeEntryChanged && (mePtr->namePtr != NULL)) {
2005 oldCascadeMenuRefPtr = TkFindMenuReferencesObj(menuPtr->interp,
2006 mePtr->namePtr);
2007
2008 if ((oldCascadeMenuRefPtr != NULL)
2009 && (oldCascadeMenuRefPtr->menuPtr != NULL)) {
2010 RecursivelyDeleteMenu(oldCascadeMenuRefPtr->menuPtr);
2011 }
2012 }
2013
2014 if (ConfigureMenuEntry(mePtr, objc, objv) != TCL_OK) {
2015 return TCL_ERROR;
2016 }
2017
2018 if (cascadeEntryChanged && (mePtr->namePtr != NULL)) {
2019 if (cascadeMenuRefPtr->menuPtr != NULL) {
2020 Tcl_Obj *newObjv[2];
2021 Tcl_Obj *newCloneNamePtr;
2022 Tcl_Obj *pathNamePtr = Tcl_NewStringObj(
2023 Tk_PathName(menuListPtr->tkwin), -1);
2024 Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1);
2025 Tcl_Obj *menuObjPtr = Tcl_NewStringObj("-menu", -1);
2026
2027 Tcl_IncrRefCount(pathNamePtr);
2028 newCloneNamePtr = TkNewMenuName(menuPtr->interp,
2029 pathNamePtr,
2030 cascadeMenuRefPtr->menuPtr);
2031 Tcl_IncrRefCount(newCloneNamePtr);
2032 Tcl_IncrRefCount(normalPtr);
2033 CloneMenu(cascadeMenuRefPtr->menuPtr, newCloneNamePtr,
2034 normalPtr);
2035
2036 newObjv[0] = menuObjPtr;
2037 newObjv[1] = newCloneNamePtr;
2038 Tcl_IncrRefCount(menuObjPtr);
2039 ConfigureMenuEntry(mePtr, 2, newObjv);
2040 Tcl_DecrRefCount(newCloneNamePtr);
2041 Tcl_DecrRefCount(pathNamePtr);
2042 Tcl_DecrRefCount(normalPtr);
2043 Tcl_DecrRefCount(menuObjPtr);
2044 }
2045 }
2046 }
2047 return TCL_OK;
2048 }
2049
2050 /*
2051 *--------------------------------------------------------------
2052 *
2053 * TkGetMenuIndex --
2054 *
2055 * Parse a textual index into a menu and return the numerical
2056 * index of the indicated entry.
2057 *
2058 * Results:
2059 * A standard Tcl result. If all went well, then *indexPtr is
2060 * filled in with the entry index corresponding to string
2061 * (ranges from -1 to the number of entries in the menu minus
2062 * one). Otherwise an error message is left in the interp's result.
2063 *
2064 * Side effects:
2065 * None.
2066 *
2067 *--------------------------------------------------------------
2068 */
2069
2070 int
2071 TkGetMenuIndex(interp, menuPtr, objPtr, lastOK, indexPtr)
2072 Tcl_Interp *interp; /* For error messages. */
2073 TkMenu *menuPtr; /* Menu for which the index is being
2074 * specified. */
2075 Tcl_Obj *objPtr; /* Specification of an entry in menu. See
2076 * manual entry for valid .*/
2077 int lastOK; /* Non-zero means its OK to return index
2078 * just *after* last entry. */
2079 int *indexPtr; /* Where to store converted index. */
2080 {
2081 int i;
2082 char *string = Tcl_GetStringFromObj(objPtr, NULL);
2083
2084 if ((string[0] == 'a') && (strcmp(string, "active") == 0)) {
2085 *indexPtr = menuPtr->active;
2086 goto success;
2087 }
2088
2089 if (((string[0] == 'l') && (strcmp(string, "last") == 0))
2090 || ((string[0] == 'e') && (strcmp(string, "end") == 0))) {
2091 *indexPtr = menuPtr->numEntries - ((lastOK) ? 0 : 1);
2092 goto success;
2093 }
2094
2095 if ((string[0] == 'n') && (strcmp(string, "none") == 0)) {
2096 *indexPtr = -1;
2097 goto success;
2098 }
2099
2100 if (string[0] == '@') {
2101 if (GetIndexFromCoords(interp, menuPtr, string, indexPtr)
2102 == TCL_OK) {
2103 goto success;
2104 }
2105 }
2106
2107 if (isdigit(UCHAR(string[0]))) {
2108 if (Tcl_GetInt(interp, string, &i) == TCL_OK) {
2109 if (i >= menuPtr->numEntries) {
2110 if (lastOK) {
2111 i = menuPtr->numEntries;
2112 } else {
2113 i = menuPtr->numEntries-1;
2114 }
2115 } else if (i < 0) {
2116 i = -1;
2117 }
2118 *indexPtr = i;
2119 goto success;
2120 }
2121 Tcl_SetResult(interp, (char *) NULL, TCL_STATIC);
2122 }
2123
2124 for (i = 0; i < menuPtr->numEntries; i++) {
2125 Tcl_Obj *labelPtr = menuPtr->entries[i]->labelPtr;
2126 char *label = (labelPtr == NULL) ? NULL
2127 : Tcl_GetStringFromObj(labelPtr, NULL);
2128
2129 if ((label != NULL)
2130 && (Tcl_StringMatch(label, string))) {
2131 *indexPtr = i;
2132 goto success;
2133 }
2134 }
2135
2136 Tcl_AppendResult(interp, "bad menu entry index \"",
2137 string, "\"", (char *) NULL);
2138 return TCL_ERROR;
2139
2140 success:
2141 return TCL_OK;
2142 }
2143
2144 /*
2145 *----------------------------------------------------------------------
2146 *
2147 * MenuCmdDeletedProc --
2148 *
2149 * This procedure is invoked when a widget command is deleted. If
2150 * the widget isn't already in the process of being destroyed,
2151 * this command destroys it.
2152 *
2153 * Results:
2154 * None.
2155 *
2156 * Side effects:
2157 * The widget is destroyed.
2158 *
2159 *----------------------------------------------------------------------
2160 */
2161
2162 static void
2163 MenuCmdDeletedProc(clientData)
2164 ClientData clientData; /* Pointer to widget record for widget. */
2165 {
2166 TkMenu *menuPtr = (TkMenu *) clientData;
2167 Tk_Window tkwin = menuPtr->tkwin;
2168
2169 /*
2170 * This procedure could be invoked either because the window was
2171 * destroyed and the command was then deleted (in which case tkwin
2172 * is NULL) or because the command was deleted, and then this procedure
2173 * destroys the widget.
2174 */
2175
2176 if (tkwin != NULL) {
2177 Tk_DestroyWindow(tkwin);
2178 }
2179 }
2180
2181 /*
2182 *----------------------------------------------------------------------
2183 *
2184 * MenuNewEntry --
2185 *
2186 * This procedure allocates and initializes a new menu entry.
2187 *
2188 * Results:
2189 * The return value is a pointer to a new menu entry structure,
2190 * which has been malloc-ed, initialized, and entered into the
2191 * entry array for the menu.
2192 *
2193 * Side effects:
2194 * Storage gets allocated.
2195 *
2196 *----------------------------------------------------------------------
2197 */
2198
2199 static TkMenuEntry *
2200 MenuNewEntry(menuPtr, index, type)
2201 TkMenu *menuPtr; /* Menu that will hold the new entry. */
2202 int index; /* Where in the menu the new entry is to
2203 * go. */
2204 int type; /* The type of the new entry. */
2205 {
2206 TkMenuEntry *mePtr;
2207 TkMenuEntry **newEntries;
2208 int i;
2209
2210 /*
2211 * Create a new array of entries with an empty slot for the
2212 * new entry.
2213 */
2214
2215 newEntries = (TkMenuEntry **) ckalloc((unsigned)
2216 ((menuPtr->numEntries+1)*sizeof(TkMenuEntry *)));
2217 for (i = 0; i < index; i++) {
2218 newEntries[i] = menuPtr->entries[i];
2219 }
2220 for ( ; i < menuPtr->numEntries; i++) {
2221 newEntries[i+1] = menuPtr->entries[i];
2222 newEntries[i+1]->index = i + 1;
2223 }
2224 if (menuPtr->numEntries != 0) {
2225 ckfree((char *) menuPtr->entries);
2226 }
2227 menuPtr->entries = newEntries;
2228 menuPtr->numEntries++;
2229 mePtr = (TkMenuEntry *) ckalloc(sizeof(TkMenuEntry));
2230 menuPtr->entries[index] = mePtr;
2231 mePtr->type = type;
2232 mePtr->optionTable = menuPtr->optionTablesPtr->entryOptionTables[type];
2233 mePtr->menuPtr = menuPtr;
2234 mePtr->labelPtr = NULL;
2235 mePtr->labelLength = 0;
2236 mePtr->underline = -1;
2237 mePtr->bitmapPtr = NULL;
2238 mePtr->imagePtr = NULL;
2239 mePtr->image = NULL;
2240 mePtr->selectImagePtr = NULL;
2241 mePtr->selectImage = NULL;
2242 mePtr->accelPtr = NULL;
2243 mePtr->accelLength = 0;
2244 mePtr->state = ENTRY_DISABLED;
2245 mePtr->borderPtr = NULL;
2246 mePtr->fgPtr = NULL;
2247 mePtr->activeBorderPtr = NULL;
2248 mePtr->activeFgPtr = NULL;
2249 mePtr->fontPtr = NULL;
2250 mePtr->indicatorOn = 0;
2251 mePtr->indicatorFgPtr = NULL;
2252 mePtr->columnBreak = 0;
2253 mePtr->hideMargin = 0;
2254 mePtr->commandPtr = NULL;
2255 mePtr->namePtr = NULL;
2256 mePtr->childMenuRefPtr = NULL;
2257 mePtr->onValuePtr = NULL;
2258 mePtr->offValuePtr = NULL;
2259 mePtr->entryFlags = 0;
2260 mePtr->index = index;
2261 mePtr->nextCascadePtr = NULL;
2262 if (Tk_InitOptions(menuPtr->interp, (char *) mePtr,
2263 mePtr->optionTable, menuPtr->tkwin) != TCL_OK) {
2264 ckfree((char *) mePtr);
2265 return NULL;
2266 }
2267 TkMenuInitializeEntryDrawingFields(mePtr);
2268 if (TkpMenuNewEntry(mePtr) != TCL_OK) {
2269 Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable,
2270 menuPtr->tkwin);
2271 ckfree((char *) mePtr);
2272 return NULL;
2273 }
2274
2275 return mePtr;
2276 }
2277
2278 /*
2279 *----------------------------------------------------------------------
2280 *
2281 * MenuAddOrInsert --
2282 *
2283 * This procedure does all of the work of the "add" and "insert"
2284 * widget commands, allowing the code for these to be shared.
2285 *
2286 * Results:
2287 * A standard Tcl return value.
2288 *
2289 * Side effects:
2290 * A new menu entry is created in menuPtr.
2291 *
2292 *----------------------------------------------------------------------
2293 */
2294
2295 static int
2296 MenuAddOrInsert(interp, menuPtr, indexPtr, objc, objv)
2297 Tcl_Interp *interp; /* Used for error reporting. */
2298 TkMenu *menuPtr; /* Widget in which to create new
2299 * entry. */
2300 Tcl_Obj *indexPtr; /* Object describing index at which
2301 * to insert. NULL means insert at
2302 * end. */
2303 int objc; /* Number of elements in objv. */
2304 Tcl_Obj *CONST objv[]; /* Arguments to command: first arg
2305 * is type of entry, others are
2306 * config options. */
2307 {
2308 int type, index;
2309 TkMenuEntry *mePtr;
2310 TkMenu *menuListPtr;
2311
2312 if (indexPtr != NULL) {
2313 if (TkGetMenuIndex(interp, menuPtr, indexPtr, 1, &index)
2314 != TCL_OK) {
2315 return TCL_ERROR;
2316 }
2317 } else {
2318 index = menuPtr->numEntries;
2319 }
2320 if (index < 0) {
2321 char *indexString = Tcl_GetStringFromObj(indexPtr, NULL);
2322 Tcl_AppendResult(interp, "bad index \"", indexString, "\"",
2323 (char *) NULL);
2324 return TCL_ERROR;
2325 }
2326 if (menuPtr->tearoff && (index == 0)) {
2327 index = 1;
2328 }
2329
2330 /*
2331 * Figure out the type of the new entry.
2332 */
2333
2334 if (Tcl_GetIndexFromObj(interp, objv[0], menuEntryTypeStrings,
2335 "menu entry type", 0, &type) != TCL_OK) {
2336 return TCL_ERROR;
2337 }
2338
2339 /*
2340 * Now we have to add an entry for every instance related to this menu.
2341 */
2342
2343 for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL;
2344 menuListPtr = menuListPtr->nextInstancePtr) {
2345
2346 mePtr = MenuNewEntry(menuListPtr, index, type);
2347 if (mePtr == NULL) {
2348 return TCL_ERROR;
2349 }
2350 if (ConfigureMenuEntry(mePtr, objc - 1, objv + 1) != TCL_OK) {
2351 TkMenu *errorMenuPtr;
2352 int i;
2353
2354 for (errorMenuPtr = menuPtr->masterMenuPtr;
2355 errorMenuPtr != NULL;
2356 errorMenuPtr = errorMenuPtr->nextInstancePtr) {
2357 Tcl_EventuallyFree((ClientData) errorMenuPtr->entries[index],
2358 DestroyMenuEntry);
2359 for (i = index; i < errorMenuPtr->numEntries - 1; i++) {
2360 errorMenuPtr->entries[i] = errorMenuPtr->entries[i + 1];
2361 errorMenuPtr->entries[i]->index = i;
2362 }
2363 errorMenuPtr->numEntries--;
2364 if (errorMenuPtr->numEntries == 0) {
2365 ckfree((char *) errorMenuPtr->entries);
2366 errorMenuPtr->entries = NULL;
2367 }
2368 if (errorMenuPtr == menuListPtr) {
2369 break;
2370 }
2371 }
2372 return TCL_ERROR;
2373 }
2374
2375 /*
2376 * If a menu has cascades, then every instance of the menu has
2377 * to have its own parallel cascade structure. So adding an
2378 * entry to a menu with clones means that the menu that the
2379 * entry points to has to be cloned for every clone the
2380 * master menu has. This is special case #2 in the comment
2381 * at the top of this file.
2382 */
2383
2384 if ((menuPtr != menuListPtr) && (type == CASCADE_ENTRY)) {
2385 if ((mePtr->namePtr != NULL)
2386 && (mePtr->childMenuRefPtr != NULL)
2387 && (mePtr->childMenuRefPtr->menuPtr != NULL)) {
2388 TkMenu *cascadeMenuPtr =
2389 mePtr->childMenuRefPtr->menuPtr->masterMenuPtr;
2390 Tcl_Obj *newCascadePtr;
2391 Tcl_Obj *menuNamePtr = Tcl_NewStringObj("-menu", -1);
2392 Tcl_Obj *windowNamePtr =
2393 Tcl_NewStringObj(Tk_PathName(menuListPtr->tkwin), -1);
2394 Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1);
2395 Tcl_Obj *newObjv[2];
2396 TkMenuReferences *menuRefPtr;
2397
2398 Tcl_IncrRefCount(windowNamePtr);
2399 newCascadePtr = TkNewMenuName(menuListPtr->interp,
2400 windowNamePtr, cascadeMenuPtr);
2401 Tcl_IncrRefCount(newCascadePtr);
2402 Tcl_IncrRefCount(normalPtr);
2403 CloneMenu(cascadeMenuPtr, newCascadePtr, normalPtr);
2404
2405 menuRefPtr = TkFindMenuReferencesObj(menuListPtr->interp,
2406 newCascadePtr);
2407 if (menuRefPtr == NULL) {
2408 panic("CloneMenu failed inside of MenuAddOrInsert.");
2409 }
2410 newObjv[0] = menuNamePtr;
2411 newObjv[1] = newCascadePtr;
2412 Tcl_IncrRefCount(menuNamePtr);
2413 Tcl_IncrRefCount(newCascadePtr);
2414 ConfigureMenuEntry(mePtr, 2, newObjv);
2415 Tcl_DecrRefCount(newCascadePtr);
2416 Tcl_DecrRefCount(menuNamePtr);
2417 Tcl_DecrRefCount(windowNamePtr);
2418 Tcl_DecrRefCount(normalPtr);
2419 }
2420 }
2421 }
2422 return TCL_OK;
2423 }
2424
2425 /*
2426 *--------------------------------------------------------------
2427 *
2428 * MenuVarProc --
2429 *
2430 * This procedure is invoked when someone changes the
2431 * state variable associated with a radiobutton or checkbutton
2432 * menu entry. The entry's selected state is set to match
2433 * the value of the variable.
2434 *
2435 * Results:
2436 * NULL is always returned.
2437 *
2438 * Side effects:
2439 * The menu entry may become selected or deselected.
2440 *
2441 *--------------------------------------------------------------
2442 */
2443
2444 static char *
2445 MenuVarProc(clientData, interp, name1, name2, flags)
2446 ClientData clientData; /* Information about menu entry. */
2447 Tcl_Interp *interp; /* Interpreter containing variable. */
2448 char *name1; /* First part of variable's name. */
2449 char *name2; /* Second part of variable's name. */
2450 int flags; /* Describes what just happened. */
2451 {
2452 TkMenuEntry *mePtr = (TkMenuEntry *) clientData;
2453 TkMenu *menuPtr;
2454 char *value;
2455 char *name = Tcl_GetStringFromObj(mePtr->namePtr, NULL);
2456 char *onValue;
2457
2458 menuPtr = mePtr->menuPtr;
2459
2460 /*
2461 * If the variable is being unset, then re-establish the
2462 * trace unless the whole interpreter is going away.
2463 */
2464
2465 if (flags & TCL_TRACE_UNSETS) {
2466 mePtr->entryFlags &= ~ENTRY_SELECTED;
2467 if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
2468 Tcl_TraceVar(interp, name,
2469 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
2470 MenuVarProc, clientData);
2471 }
2472 TkpConfigureMenuEntry(mePtr);
2473 TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL);
2474 return (char *) NULL;
2475 }
2476
2477 /*
2478 * Use the value of the variable to update the selected status of
2479 * the menu entry.
2480 */
2481
2482 value = Tcl_GetVar(interp, name, TCL_GLOBAL_ONLY);
2483 if (value == NULL) {
2484 value = "";
2485 }
2486 if (mePtr->onValuePtr != NULL) {
2487 onValue = Tcl_GetStringFromObj(mePtr->onValuePtr, NULL);
2488 if (strcmp(value, onValue) == 0) {
2489 if (mePtr->entryFlags & ENTRY_SELECTED) {
2490 return (char *) NULL;
2491 }
2492 mePtr->entryFlags |= ENTRY_SELECTED;
2493 } else if (mePtr->entryFlags & ENTRY_SELECTED) {
2494 mePtr->entryFlags &= ~ENTRY_SELECTED;
2495 } else {
2496 return (char *) NULL;
2497 }
2498 } else {
2499 return (char *) NULL;
2500 }
2501 TkpConfigureMenuEntry(mePtr);
2502 TkEventuallyRedrawMenu(menuPtr, mePtr);
2503 return (char *) NULL;
2504 }
2505
2506 /*
2507 *----------------------------------------------------------------------
2508 *
2509 * TkActivateMenuEntry --
2510 *
2511 * This procedure is invoked to make a particular menu entry
2512 * the active one, deactivating any other entry that might
2513 * currently be active.
2514 *
2515 * Results:
2516 * The return value is a standard Tcl result (errors can occur
2517 * while posting and unposting submenus).
2518 *
2519 * Side effects:
2520 * Menu entries get redisplayed, and the active entry changes.
2521 * Submenus may get posted and unposted.
2522 *
2523 *----------------------------------------------------------------------
2524 */
2525
2526 int
2527 TkActivateMenuEntry(menuPtr, index)
2528 register TkMenu *menuPtr; /* Menu in which to activate. */
2529 int index; /* Index of entry to activate, or
2530 * -1 to deactivate all entries. */
2531 {
2532 register TkMenuEntry *mePtr;
2533 int result = TCL_OK;
2534
2535 if (menuPtr->active >= 0) {
2536 mePtr = menuPtr->entries[menuPtr->active];
2537
2538 /*
2539 * Don't change the state unless it's currently active (state
2540 * might already have been changed to disabled).
2541 */
2542
2543 if (mePtr->state == ENTRY_ACTIVE) {
2544 mePtr->state = ENTRY_NORMAL;
2545 }
2546 TkEventuallyRedrawMenu(menuPtr, menuPtr->entries[menuPtr->active]);
2547 }
2548 menuPtr->active = index;
2549 if (index >= 0) {
2550 mePtr = menuPtr->entries[index];
2551 mePtr->state = ENTRY_ACTIVE;
2552 TkEventuallyRedrawMenu(menuPtr, mePtr);
2553 }
2554 return result;
2555 }
2556
2557 /*
2558 *----------------------------------------------------------------------
2559 *
2560 * TkPostCommand --
2561 *
2562 * Execute the postcommand for the given menu.
2563 *
2564 * Results:
2565 * The return value is a standard Tcl result (errors can occur
2566 * while the postcommands are being processed).
2567 *
2568 * Side effects:
2569 * Since commands can get executed while this routine is being executed,
2570 * the entire world can change.
2571 *
2572 *----------------------------------------------------------------------
2573 */
2574
2575 int
2576 TkPostCommand(menuPtr)
2577 TkMenu *menuPtr;
2578 {
2579 int result;
2580
2581 /*
2582 * If there is a command for the menu, execute it. This
2583 * may change the size of the menu, so be sure to recompute
2584 * the menu's geometry if needed.
2585 */
2586
2587 if (menuPtr->postCommandPtr != NULL) {
2588 Tcl_Obj *postCommandPtr = menuPtr->postCommandPtr;
2589
2590 Tcl_IncrRefCount(postCommandPtr);
2591 result = Tcl_EvalObjEx(menuPtr->interp, postCommandPtr,
2592 TCL_EVAL_GLOBAL);
2593 Tcl_DecrRefCount(postCommandPtr);
2594 if (result != TCL_OK) {
2595 return result;
2596 }
2597 TkRecomputeMenu(menuPtr);
2598 }
2599 return TCL_OK;
2600 }
2601
2602 /*
2603 *--------------------------------------------------------------
2604 *
2605 * CloneMenu --
2606 *
2607 * Creates a child copy of the menu. It will be inserted into
2608 * the menu's instance chain. All attributes and entry
2609 * attributes will be duplicated.
2610 *
2611 * Results:
2612 * A standard Tcl result.
2613 *
2614 * Side effects:
2615 * Allocates storage. After the menu is created, any
2616 * configuration done with this menu or any related one
2617 * will be reflected in all of them.
2618 *
2619 *--------------------------------------------------------------
2620 */
2621
2622 static int
2623 CloneMenu(menuPtr, newMenuNamePtr, newMenuTypePtr)
2624 TkMenu *menuPtr; /* The menu we are going to clone */
2625 Tcl_Obj *newMenuNamePtr; /* The name to give the new menu */
2626 Tcl_Obj *newMenuTypePtr; /* What kind of menu is this, a normal menu
2627 * a menubar, or a tearoff? */
2628 {
2629 int returnResult;
2630 int menuType, i;
2631 TkMenuReferences *menuRefPtr;
2632 Tcl_Obj *menuDupCommandArray[4];
2633
2634 if (newMenuTypePtr == NULL) {
2635 menuType = MASTER_MENU;
2636 } else {
2637 if (Tcl_GetIndexFromObj(menuPtr->interp, newMenuTypePtr,
2638 menuTypeStrings, "menu type", 0, &menuType) != TCL_OK) {
2639 return TCL_ERROR;
2640 }
2641 }
2642
2643 menuDupCommandArray[0] = Tcl_NewStringObj("tkMenuDup", -1);
2644 menuDupCommandArray[1] = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1);
2645 menuDupCommandArray[2] = newMenuNamePtr;
2646 if (newMenuTypePtr == NULL) {
2647 menuDupCommandArray[3] = Tcl_NewStringObj("normal", -1);
2648 } else {
2649 menuDupCommandArray[3] = newMenuTypePtr;
2650 }
2651 for (i = 0; i < 4; i++) {
2652 Tcl_IncrRefCount(menuDupCommandArray[i]);
2653 }
2654 Tcl_Preserve((ClientData) menuPtr);
2655 returnResult = Tcl_EvalObjv(menuPtr->interp, 4, menuDupCommandArray, 0);
2656 for (i = 0; i < 4; i++) {
2657 Tcl_DecrRefCount(menuDupCommandArray[i]);
2658 }
2659
2660 /*
2661 * Make sure the tcl command actually created the clone.
2662 */
2663
2664 if ((returnResult == TCL_OK) &&
2665 ((menuRefPtr = TkFindMenuReferencesObj(menuPtr->interp,
2666 newMenuNamePtr)) != (TkMenuReferences *) NULL)
2667 && (menuPtr->numEntries == menuRefPtr->menuPtr->numEntries)) {
2668 TkMenu *newMenuPtr = menuRefPtr->menuPtr;
2669 Tcl_Obj *newObjv[3];
2670 char *newArgv[3];
2671 int i, numElements;
2672
2673 /*
2674 * Now put this newly created menu into the parent menu's instance
2675 * chain.
2676 */
2677
2678 if (menuPtr->nextInstancePtr == NULL) {
2679 menuPtr->nextInstancePtr = newMenuPtr;
2680 newMenuPtr->masterMenuPtr = menuPtr->masterMenuPtr;
2681 } else {
2682 TkMenu *masterMenuPtr;
2683
2684 masterMenuPtr = menuPtr->masterMenuPtr;
2685 newMenuPtr->nextInstancePtr = masterMenuPtr->nextInstancePtr;
2686 masterMenuPtr->nextInstancePtr = newMenuPtr;
2687 newMenuPtr->masterMenuPtr = masterMenuPtr;
2688 }
2689
2690 /*
2691 * Add the master menu's window to the bind tags for this window
2692 * after this window's tag. This is so the user can bind to either
2693 * this clone (which may not be easy to do) or the entire menu
2694 * clone structure.
2695 */
2696
2697 newArgv[0] = "bindtags";
2698 newArgv[1] = Tk_PathName(newMenuPtr->tkwin);
2699 if (Tk_BindtagsCmd((ClientData)newMenuPtr->tkwin,
2700 newMenuPtr->interp, 2, newArgv) == TCL_OK) {
2701 char *windowName;
2702 Tcl_Obj *bindingsPtr =
2703 Tcl_DuplicateObj(Tcl_GetObjResult(newMenuPtr->interp));
2704 Tcl_Obj *elementPtr;
2705
2706 Tcl_ListObjLength(newMenuPtr->interp, bindingsPtr, &numElements);
2707 for (i = 0; i < numElements; i++) {
2708 Tcl_ListObjIndex(newMenuPtr->interp, bindingsPtr, i,
2709 &elementPtr);
2710 windowName = Tcl_GetStringFromObj(elementPtr, NULL);
2711 if (strcmp(windowName, Tk_PathName(newMenuPtr->tkwin))
2712 == 0) {
2713 Tcl_Obj *newElementPtr = Tcl_NewStringObj(
2714 Tk_PathName(newMenuPtr->masterMenuPtr->tkwin), -1);
2715 Tcl_IncrRefCount(newElementPtr);
2716 Tcl_ListObjReplace(menuPtr->interp, bindingsPtr,
2717 i + 1, 0, 1, &newElementPtr);
2718 newArgv[2] = Tcl_GetStringFromObj(bindingsPtr, NULL);
2719 Tk_BindtagsCmd((ClientData)newMenuPtr->tkwin,
2720 menuPtr->interp, 3, newArgv);
2721 break;
2722 }
2723 }
2724 Tcl_DecrRefCount(bindingsPtr);
2725 }
2726 Tcl_ResetResult(menuPtr->interp);
2727
2728 /*
2729 * Clone all of the cascade menus that this menu points to.
2730 */
2731
2732 for (i = 0; i < menuPtr->numEntries; i++) {
2733 TkMenuReferences *cascadeRefPtr;
2734 TkMenu *oldCascadePtr;
2735
2736 if ((menuPtr->entries[i]->type == CASCADE_ENTRY)
2737 && (menuPtr->entries[i]->namePtr != NULL)) {
2738 cascadeRefPtr =
2739 TkFindMenuReferencesObj(menuPtr->interp,
2740 menuPtr->entries[i]->namePtr);
2741 if ((cascadeRefPtr != NULL) && (cascadeRefPtr->menuPtr)) {
2742 Tcl_Obj *windowNamePtr =
2743 Tcl_NewStringObj(Tk_PathName(newMenuPtr->tkwin),
2744 -1);
2745 Tcl_Obj *newCascadePtr;
2746
2747 oldCascadePtr = cascadeRefPtr->menuPtr;
2748
2749 Tcl_IncrRefCount(windowNamePtr);
2750 newCascadePtr = TkNewMenuName(menuPtr->interp,
2751 windowNamePtr, oldCascadePtr);
2752 Tcl_IncrRefCount(newCascadePtr);
2753 CloneMenu(oldCascadePtr, newCascadePtr, NULL);
2754
2755 newObjv[0] = Tcl_NewStringObj("-menu", -1);
2756 newObjv[1] = newCascadePtr;
2757 Tcl_IncrRefCount(newObjv[0]);
2758 ConfigureMenuEntry(newMenuPtr->entries[i], 2, newObjv);
2759 Tcl_DecrRefCount(newObjv[0]);
2760 Tcl_DecrRefCount(newCascadePtr);
2761 Tcl_DecrRefCount(windowNamePtr);
2762 }
2763 }
2764 }
2765
2766 returnResult = TCL_OK;
2767 } else {
2768 returnResult = TCL_ERROR;
2769 }
2770 Tcl_Release((ClientData) menuPtr);
2771 return returnResult;
2772 }
2773
2774 /*
2775 *----------------------------------------------------------------------
2776 *
2777 * MenuDoYPosition --
2778 *
2779 * Given arguments from an option command line, returns the Y position.
2780 *
2781 * Results:
2782 * Returns TCL_OK or TCL_Error
2783 *
2784 * Side effects:
2785 * yPosition is set to the Y-position of the menu entry.
2786 *
2787 *----------------------------------------------------------------------
2788 */
2789
2790 static int
2791 MenuDoYPosition(interp, menuPtr, objPtr)
2792 Tcl_Interp *interp;
2793 TkMenu *menuPtr;
2794 Tcl_Obj *objPtr;
2795 {
2796 int index;
2797
2798 TkRecomputeMenu(menuPtr);
2799 if (TkGetMenuIndex(interp, menuPtr, objPtr, 0, &index) != TCL_OK) {
2800 goto error;
2801 }
2802 Tcl_ResetResult(interp);
2803 if (index < 0) {
2804 Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
2805 } else {
2806 Tcl_SetObjResult(interp, Tcl_NewIntObj(menuPtr->entries[index]->y));
2807 }
2808
2809 return TCL_OK;
2810
2811 error:
2812 return TCL_ERROR;
2813 }
2814
2815 /*
2816 *----------------------------------------------------------------------
2817 *
2818 * GetIndexFromCoords --
2819 *
2820 * Given a string of the form "@int", return the menu item corresponding
2821 * to int.
2822 *
2823 * Results:
2824 * If int is a valid number, *indexPtr will be the number of the menuentry
2825 * that is the correct height. If int is invaled, *indexPtr will be
2826 * unchanged. Returns appropriate Tcl error number.
2827 *
2828 * Side effects:
2829 * If int is invalid, interp's result will set to NULL.
2830 *
2831 *----------------------------------------------------------------------
2832 */
2833
2834 static int
2835 GetIndexFromCoords(interp, menuPtr, string, indexPtr)
2836 Tcl_Interp *interp; /* interp of menu */
2837 TkMenu *menuPtr; /* the menu we are searching */
2838 char *string; /* The @string we are parsing */
2839 int *indexPtr; /* The index of the item that matches */
2840 {
2841 int x, y, i;
2842 char *p, *end;
2843
2844 TkRecomputeMenu(menuPtr);
2845 p = string + 1;
2846 y = strtol(p, &end, 0);
2847 if (end == p) {
2848 goto error;
2849 }
2850 if (*end == ',') {
2851 x = y;
2852 p = end + 1;
2853 y = strtol(p, &end, 0);
2854 if (end == p) {
2855 goto error;
2856 }
2857 } else {
2858 Tk_GetPixelsFromObj(interp, menuPtr->tkwin,
2859 menuPtr->borderWidthPtr, &x);
2860 }
2861
2862 for (i = 0; i < menuPtr->numEntries; i++) {
2863 if ((x >= menuPtr->entries[i]->x) && (y >= menuPtr->entries[i]->y)
2864 && (x < (menuPtr->entries[i]->x + menuPtr->entries[i]->width))
2865 && (y < (menuPtr->entries[i]->y
2866 + menuPtr->entries[i]->height))) {
2867 break;
2868 }
2869 }
2870 if (i >= menuPtr->numEntries) {
2871 /* i = menuPtr->numEntries - 1; */
2872 i = -1;
2873 }
2874 *indexPtr = i;
2875 return TCL_OK;
2876
2877 error:
2878 Tcl_SetResult(interp, (char *) NULL, TCL_STATIC);
2879 return TCL_ERROR;
2880 }
2881
2882 /*
2883 *----------------------------------------------------------------------
2884 *
2885 * RecursivelyDeleteMenu --
2886 *
2887 * Deletes a menu and any cascades underneath it. Used for deleting
2888 * instances when a menu is no longer being used as a menubar,
2889 * for instance.
2890 *
2891 * Results:
2892 * None.
2893 *
2894 * Side effects:
2895 * Destroys the menu and all cascade menus underneath it.
2896 *
2897 *----------------------------------------------------------------------
2898 */
2899
2900 static void
2901 RecursivelyDeleteMenu(menuPtr)
2902 TkMenu *menuPtr; /* The menubar instance we are deleting */
2903 {
2904 int i;
2905 TkMenuEntry *mePtr;
2906
2907 for (i = 0; i < menuPtr->numEntries; i++) {
2908 mePtr = menuPtr->entries[i];
2909 if ((mePtr->type == CASCADE_ENTRY)
2910 && (mePtr->childMenuRefPtr != NULL)
2911 && (mePtr->childMenuRefPtr->menuPtr != NULL)) {
2912 RecursivelyDeleteMenu(mePtr->childMenuRefPtr->menuPtr);
2913 }
2914 }
2915 Tk_DestroyWindow(menuPtr->tkwin);
2916 }
2917
2918 /*
2919 *----------------------------------------------------------------------
2920 *
2921 * TkNewMenuName --
2922 *
2923 * Makes a new unique name for a cloned menu. Will be a child
2924 * of oldName.
2925 *
2926 * Results:
2927 * Returns a char * which has been allocated; caller must free.
2928 *
2929 * Side effects:
2930 * Memory is allocated.
2931 *
2932 *----------------------------------------------------------------------
2933 */
2934
2935 Tcl_Obj *
2936 TkNewMenuName(interp, parentPtr, menuPtr)
2937 Tcl_Interp *interp; /* The interp the new name has to live in.*/
2938 Tcl_Obj *parentPtr; /* The prefix path of the new name. */
2939 TkMenu *menuPtr; /* The menu we are cloning. */
2940 {
2941 Tcl_Obj *resultPtr = NULL; /* Initialization needed only to prevent
2942 * compiler warning. */
2943 Tcl_Obj *childPtr;
2944 char *destString;
2945 int i;
2946 int doDot;
2947 Tcl_CmdInfo cmdInfo;
2948 Tcl_HashTable *nameTablePtr = NULL;
2949 TkWindow *winPtr = (TkWindow *) menuPtr->tkwin;
2950 char *parentName = Tcl_GetStringFromObj(parentPtr, NULL);
2951
2952 if (winPtr->mainPtr != NULL) {
2953 nameTablePtr = &(winPtr->mainPtr->nameTable);
2954 }
2955
2956 doDot = parentName[strlen(parentName) - 1] != '.';
2957
2958 childPtr = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1);
2959 for (destString = Tcl_GetStringFromObj(childPtr, NULL);
2960 *destString != '\0'; destString++) {
2961 if (*destString == '.') {
2962 *destString = '#';
2963 }
2964 }
2965
2966 for (i = 0; ; i++) {
2967 if (i == 0) {
2968 resultPtr = Tcl_DuplicateObj(parentPtr);
2969 if (doDot) {
2970 Tcl_AppendToObj(resultPtr, ".", -1);
2971 }
2972 Tcl_AppendObjToObj(resultPtr, childPtr);
2973 } else {
2974 Tcl_Obj *intPtr;
2975
2976 Tcl_DecrRefCount(resultPtr);
2977 resultPtr = Tcl_DuplicateObj(parentPtr);
2978 if (doDot) {
2979 Tcl_AppendToObj(resultPtr, ".", -1);
2980 }
2981 Tcl_AppendObjToObj(resultPtr, childPtr);
2982 intPtr = Tcl_NewIntObj(i);
2983 Tcl_AppendObjToObj(resultPtr, intPtr);
2984 Tcl_DecrRefCount(intPtr);
2985 }
2986 destString = Tcl_GetStringFromObj(resultPtr, NULL);
2987 if ((Tcl_GetCommandInfo(interp, destString, &cmdInfo) == 0)
2988 && ((nameTablePtr == NULL)
2989 || (Tcl_FindHashEntry(nameTablePtr, destString) == NULL))) {
2990 break;
2991 }
2992 }
2993 Tcl_DecrRefCount(childPtr);
2994 return resultPtr;
2995 }
2996
2997 /*
2998 *----------------------------------------------------------------------
2999 *
3000 * TkSetWindowMenuBar --
3001 *
3002 * Associates a menu with a window. Called by ConfigureFrame in
3003 * in response to a "-menu .foo" configuration option for a top
3004 * level.
3005 *
3006 * Results:
3007 * None.
3008 *
3009 * Side effects:
3010 * The old menu clones for the menubar are thrown away, and a
3011 * handler is set up to allocate the new ones.
3012 *
3013 *----------------------------------------------------------------------
3014 */
3015 void
3016 TkSetWindowMenuBar(interp, tkwin, oldMenuName, menuName)
3017 Tcl_Interp *interp; /* The interpreter the toplevel lives in. */
3018 Tk_Window tkwin; /* The toplevel window */
3019 char *oldMenuName; /* The name of the menubar previously set in
3020 * this toplevel. NULL means no menu was
3021 * set previously. */
3022 char *menuName; /* The name of the new menubar that the
3023 * toplevel needs to be set to. NULL means
3024 * that their is no menu now. */
3025 {
3026 TkMenuTopLevelList *topLevelListPtr, *prevTopLevelPtr;
3027 TkMenu *menuPtr;
3028 TkMenuReferences *menuRefPtr;
3029
3030 TkMenuInit();
3031
3032 /*
3033 * Destroy the menubar instances of the old menu. Take this window
3034 * out of the old menu's top level reference list.
3035 */
3036
3037 if (oldMenuName != NULL) {
3038 menuRefPtr = TkFindMenuReferences(interp, oldMenuName);
3039 if (menuRefPtr != NULL) {
3040
3041 /*
3042 * Find the menubar instance that is to be removed. Destroy
3043 * it and all of the cascades underneath it.
3044 */
3045
3046 if (menuRefPtr->menuPtr != NULL) {
3047 TkMenu *instancePtr;
3048
3049 menuPtr = menuRefPtr->menuPtr;
3050
3051 for (instancePtr = menuPtr->masterMenuPtr;
3052 instancePtr != NULL;
3053 instancePtr = instancePtr->nextInstancePtr) {
3054 if (instancePtr->menuType == MENUBAR
3055 && instancePtr->parentTopLevelPtr == tkwin) {
3056 RecursivelyDeleteMenu(instancePtr);
3057 break;
3058 }
3059 }
3060 }
3061
3062 /*
3063 * Now we need to remove this toplevel from the list of toplevels
3064 * that reference this menu.
3065 */
3066
3067 for (topLevelListPtr = menuRefPtr->topLevelListPtr,
3068 prevTopLevelPtr = NULL;
3069 (topLevelListPtr != NULL)
3070 && (topLevelListPtr->tkwin != tkwin);
3071 prevTopLevelPtr = topLevelListPtr,
3072 topLevelListPtr = topLevelListPtr->nextPtr) {
3073
3074 /*
3075 * Empty loop body.
3076 */
3077
3078 }
3079
3080 /*
3081 * Now we have found the toplevel reference that matches the
3082 * tkwin; remove this reference from the list.
3083 */
3084
3085 if (topLevelListPtr != NULL) {
3086 if (prevTopLevelPtr == NULL) {
3087 menuRefPtr->topLevelListPtr =
3088 menuRefPtr->topLevelListPtr->nextPtr;
3089 } else {
3090 prevTopLevelPtr->nextPtr = topLevelListPtr->nextPtr;
3091 }
3092 ckfree((char *) topLevelListPtr);
3093 TkFreeMenuReferences(menuRefPtr);
3094 }
3095 }
3096 }
3097
3098 /*
3099 * Now, add the clone references for the new menu.
3100 */
3101
3102 if (menuName != NULL && menuName[0] != 0) {
3103 TkMenu *menuBarPtr = NULL;
3104
3105 menuRefPtr = TkCreateMenuReferences(interp, menuName);
3106
3107 menuPtr = menuRefPtr->menuPtr;
3108 if (menuPtr != NULL) {
3109 Tcl_Obj *cloneMenuPtr;
3110 TkMenuReferences *cloneMenuRefPtr;
3111 Tcl_Obj *newObjv[4];
3112 Tcl_Obj *windowNamePtr = Tcl_NewStringObj(Tk_PathName(tkwin),
3113 -1);
3114 Tcl_Obj *menubarPtr = Tcl_NewStringObj("menubar", -1);
3115
3116 /*
3117 * Clone the menu and all of the cascades underneath it.
3118 */
3119
3120 Tcl_IncrRefCount(windowNamePtr);
3121 cloneMenuPtr = TkNewMenuName(interp, windowNamePtr,
3122 menuPtr);
3123 Tcl_IncrRefCount(cloneMenuPtr);
3124 Tcl_IncrRefCount(menubarPtr);
3125 CloneMenu(menuPtr, cloneMenuPtr, menubarPtr);
3126
3127 cloneMenuRefPtr = TkFindMenuReferencesObj(interp, cloneMenuPtr);
3128 if ((cloneMenuRefPtr != NULL)
3129 && (cloneMenuRefPtr->menuPtr != NULL)) {
3130 Tcl_Obj *cursorPtr = Tcl_NewStringObj("-cursor", -1);
3131 Tcl_Obj *nullPtr = Tcl_NewObj();
3132 cloneMenuRefPtr->menuPtr->parentTopLevelPtr = tkwin;
3133 menuBarPtr = cloneMenuRefPtr->menuPtr;
3134 newObjv[0] = cursorPtr;
3135 newObjv[1] = nullPtr;
3136 Tcl_IncrRefCount(cursorPtr);
3137 Tcl_IncrRefCount(nullPtr);
3138 ConfigureMenu(menuPtr->interp, cloneMenuRefPtr->menuPtr,
3139 2, newObjv);
3140 Tcl_DecrRefCount(cursorPtr);
3141 Tcl_DecrRefCount(nullPtr);
3142 }
3143
3144 TkpSetWindowMenuBar(tkwin, menuBarPtr);
3145 Tcl_DecrRefCount(cloneMenuPtr);
3146 Tcl_DecrRefCount(menubarPtr);
3147 Tcl_DecrRefCount(windowNamePtr);
3148 } else {
3149 TkpSetWindowMenuBar(tkwin, NULL);
3150 }
3151
3152
3153 /*
3154 * Add this window to the menu's list of windows that refer
3155 * to this menu.
3156 */
3157
3158 topLevelListPtr = (TkMenuTopLevelList *)
3159 ckalloc(sizeof(TkMenuTopLevelList));
3160 topLevelListPtr->tkwin = tkwin;
3161 topLevelListPtr->nextPtr = menuRefPtr->topLevelListPtr;
3162 menuRefPtr->topLevelListPtr = topLevelListPtr;
3163 } else {
3164 TkpSetWindowMenuBar(tkwin, NULL);
3165 }
3166 TkpSetMainMenubar(interp, tkwin, menuName);
3167 }
3168
3169 /*
3170 *----------------------------------------------------------------------
3171 *
3172 * DestroyMenuHashTable --
3173 *
3174 * Called when an interp is deleted and a menu hash table has
3175 * been set in it.
3176 *
3177 * Results:
3178 * None.
3179 *
3180 * Side effects:
3181 * The hash table is destroyed.
3182 *
3183 *----------------------------------------------------------------------
3184 */
3185
3186 static void
3187 DestroyMenuHashTable(clientData, interp)
3188 ClientData clientData; /* The menu hash table we are destroying */
3189 Tcl_Interp *interp; /* The interpreter we are destroying */
3190 {
3191 Tcl_DeleteHashTable((Tcl_HashTable *) clientData);
3192 ckfree((char *) clientData);
3193 }
3194
3195 /*
3196 *----------------------------------------------------------------------
3197 *
3198 * TkGetMenuHashTable --
3199 *
3200 * For a given interp, give back the menu hash table that goes with
3201 * it. If the hash table does not exist, it is created.
3202 *
3203 * Results:
3204 * Returns a hash table pointer.
3205 *
3206 * Side effects:
3207 * A new hash table is created if there were no table in the interp
3208 * originally.
3209 *
3210 *----------------------------------------------------------------------
3211 */
3212
3213 Tcl_HashTable *
3214 TkGetMenuHashTable(interp)
3215 Tcl_Interp *interp; /* The interp we need the hash table in.*/
3216 {
3217 Tcl_HashTable *menuTablePtr;
3218
3219 menuTablePtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, MENU_HASH_KEY,
3220 NULL);
3221 if (menuTablePtr == NULL) {
3222 menuTablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
3223 Tcl_InitHashTable(menuTablePtr, TCL_STRING_KEYS);
3224 Tcl_SetAssocData(interp, MENU_HASH_KEY, DestroyMenuHashTable,
3225 (ClientData) menuTablePtr);
3226 }
3227 return menuTablePtr;
3228 }
3229
3230 /*
3231 *----------------------------------------------------------------------
3232 *
3233 * TkCreateMenuReferences --
3234 *
3235 * Given a pathname, gives back a pointer to a TkMenuReferences structure.
3236 * If a reference is not already in the hash table, one is created.
3237 *
3238 * Results:
3239 * Returns a pointer to a menu reference structure. Should not
3240 * be freed by calller; when a field of the reference is cleared,
3241 * TkFreeMenuReferences should be called.
3242 *
3243 * Side effects:
3244 * A new hash table entry is created if there were no references
3245 * to the menu originally.
3246 *
3247 *----------------------------------------------------------------------
3248 */
3249
3250 TkMenuReferences *
3251 TkCreateMenuReferences(interp, pathName)
3252 Tcl_Interp *interp;
3253 char *pathName; /* The path of the menu widget */
3254 {
3255 Tcl_HashEntry *hashEntryPtr;
3256 TkMenuReferences *menuRefPtr;
3257 int newEntry;
3258 Tcl_HashTable *menuTablePtr = TkGetMenuHashTable(interp);
3259
3260 hashEntryPtr = Tcl_CreateHashEntry(menuTablePtr, pathName, &newEntry);
3261 if (newEntry) {
3262 menuRefPtr = (TkMenuReferences *) ckalloc(sizeof(TkMenuReferences));
3263 menuRefPtr->menuPtr = NULL;
3264 menuRefPtr->topLevelListPtr = NULL;
3265 menuRefPtr->parentEntryPtr = NULL;
3266 menuRefPtr->hashEntryPtr = hashEntryPtr;
3267 Tcl_SetHashValue(hashEntryPtr, (char *) menuRefPtr);
3268 } else {
3269 menuRefPtr = (TkMenuReferences *) Tcl_GetHashValue(hashEntryPtr);
3270 }
3271 return menuRefPtr;
3272 }
3273
3274 /*
3275 *----------------------------------------------------------------------
3276 *
3277 * TkFindMenuReferences --
3278 *
3279 * Given a pathname, gives back a pointer to the TkMenuReferences
3280 * structure.
3281 *
3282 * Results:
3283 * Returns a pointer to a menu reference structure. Should not
3284 * be freed by calller; when a field of the reference is cleared,
3285 * TkFreeMenuReferences should be called. Returns NULL if no reference
3286 * with this pathname exists.
3287 *
3288 * Side effects:
3289 * None.
3290 *
3291 *----------------------------------------------------------------------
3292 */
3293
3294 TkMenuReferences *
3295 TkFindMenuReferences(interp, pathName)
3296 Tcl_Interp *interp; /* The interp the menu is living in. */
3297 char *pathName; /* The path of the menu widget */
3298 {
3299 Tcl_HashEntry *hashEntryPtr;
3300 TkMenuReferences *menuRefPtr = NULL;
3301 Tcl_HashTable *menuTablePtr;
3302
3303 menuTablePtr = TkGetMenuHashTable(interp);
3304 hashEntryPtr = Tcl_FindHashEntry(menuTablePtr, pathName);
3305 if (hashEntryPtr != NULL) {
3306 menuRefPtr = (TkMenuReferences *) Tcl_GetHashValue(hashEntryPtr);
3307 }
3308 return menuRefPtr;
3309 }
3310
3311 /*
3312 *----------------------------------------------------------------------
3313 *
3314 * TkFindMenuReferencesObj --
3315 *
3316 * Given a pathname, gives back a pointer to the TkMenuReferences
3317 * structure.
3318 *
3319 * Results:
3320 * Returns a pointer to a menu reference structure. Should not
3321 * be freed by calller; when a field of the reference is cleared,
3322 * TkFreeMenuReferences should be called. Returns NULL if no reference
3323 * with this pathname exists.
3324 *
3325 * Side effects:
3326 * None.
3327 *
3328 *----------------------------------------------------------------------
3329 */
3330
3331 TkMenuReferences *
3332 TkFindMenuReferencesObj(interp, objPtr)
3333 Tcl_Interp *interp; /* The interp the menu is living in. */
3334 Tcl_Obj *objPtr; /* The path of the menu widget */
3335 {
3336 char *pathName = Tcl_GetStringFromObj(objPtr, NULL);
3337 return TkFindMenuReferences(interp, pathName);
3338 }
3339
3340 /*
3341 *----------------------------------------------------------------------
3342 *
3343 * TkFreeMenuReferences --
3344 *
3345 * This is called after one of the fields in a menu reference
3346 * is cleared. It cleans up the ref if it is now empty.
3347 *
3348 * Results:
3349 * None.
3350 *
3351 * Side effects:
3352 * If this is the last field to be cleared, the menu ref is
3353 * taken out of the hash table.
3354 *
3355 *----------------------------------------------------------------------
3356 */
3357
3358 void
3359 TkFreeMenuReferences(menuRefPtr)
3360 TkMenuReferences *menuRefPtr; /* The menu reference to
3361 * free */
3362 {
3363 if ((menuRefPtr->menuPtr == NULL)
3364 && (menuRefPtr->parentEntryPtr == NULL)
3365 && (menuRefPtr->topLevelListPtr == NULL)) {
3366 Tcl_DeleteHashEntry(menuRefPtr->hashEntryPtr);
3367 ckfree((char *) menuRefPtr);
3368 }
3369 }
3370
3371 /*
3372 *----------------------------------------------------------------------
3373 *
3374 * DeleteMenuCloneEntries --
3375 *
3376 * For every clone in this clone chain, delete the menu entries
3377 * given by the parameters.
3378 *
3379 * Results:
3380 * None.
3381 *
3382 * Side effects:
3383 * The appropriate entries are deleted from all clones of this menu.
3384 *
3385 *----------------------------------------------------------------------
3386 */
3387
3388 static void
3389 DeleteMenuCloneEntries(menuPtr, first, last)
3390 TkMenu *menuPtr; /* the menu the command was issued with */
3391 int first; /* the zero-based first entry in the set
3392 * of entries to delete. */
3393 int last; /* the zero-based last entry */
3394 {
3395
3396 TkMenu *menuListPtr;
3397 int numDeleted, i;
3398
3399 numDeleted = last + 1 - first;
3400 for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL;
3401 menuListPtr = menuListPtr->nextInstancePtr) {
3402 for (i = last; i >= first; i--) {
3403 Tcl_EventuallyFree((ClientData) menuListPtr->entries[i],
3404 DestroyMenuEntry);
3405 }
3406 for (i = last + 1; i < menuListPtr->numEntries; i++) {
3407 menuListPtr->entries[i - numDeleted] = menuListPtr->entries[i];
3408 menuListPtr->entries[i - numDeleted]->index = i;
3409 }
3410 menuListPtr->numEntries -= numDeleted;
3411 if (menuListPtr->numEntries == 0) {
3412 ckfree((char *) menuListPtr->entries);
3413 menuListPtr->entries = NULL;
3414 }
3415 if ((menuListPtr->active >= first)
3416 && (menuListPtr->active <= last)) {
3417 menuListPtr->active = -1;
3418 } else if (menuListPtr->active > last) {
3419 menuListPtr->active -= numDeleted;
3420 }
3421 TkEventuallyRecomputeMenu(menuListPtr);
3422 }
3423 }
3424
3425 /*
3426 *----------------------------------------------------------------------
3427 *
3428 * TkMenuInit --
3429 *
3430 * Sets up the hash tables and the variables used by the menu package.
3431 *
3432 * Results:
3433 * None.
3434 *
3435 * Side effects:
3436 * lastMenuID gets initialized, and the parent hash and the command hash
3437 * are allocated.
3438 *
3439 *----------------------------------------------------------------------
3440 */
3441
3442 void
3443 TkMenuInit()
3444 {
3445 ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
3446 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
3447
3448 if (!menusInitialized) {
3449 Tcl_MutexLock(&menuMutex);
3450 if (!menusInitialized) {
3451 TkpMenuInit();
3452 menusInitialized = 1;
3453 }
3454 Tcl_MutexUnlock(&menuMutex);
3455 }
3456 if (!tsdPtr->menusInitialized) {
3457 TkpMenuThreadInit();
3458 tsdPtr->menusInitialized = 1;
3459 }
3460 }
3461
3462 /* End of tkmenu.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25