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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 42 - (hide annotations) (download)
Fri Oct 14 01:50:00 2016 UTC (8 years ago) by dashley
Original Path: projs/trunk/shared_source/tk_base/tkmenu.c
File MIME type: text/plain
File size: 108664 byte(s)
Move shared source code to commonize.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tk_base/tkmenu.c,v 1.1.1.1 2001/06/13 05:05:37 dtashley Exp $ */
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    
3463     /* $History: tkMenu.c $
3464     *
3465     * ***************** Version 1 *****************
3466     * User: Dtashley Date: 1/02/01 Time: 2:58a
3467     * Created in $/IjuScripter, IjuConsole/Source/Tk Base
3468     * Initial check-in.
3469     */
3470    
3471     /* End of TKMENU.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25