Mercurial > hg > xemacs-beta

comparison src/menubar-msw.c @ 251:677f6a0ee643 r20-5b24

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b24
author cvs
date Mon, 13 Aug 2007 10:19:59 +0200
parents 83b3d10dcba9
children 157b30c96d03
comparison
equal deleted inserted replaced
250:f385a461c9aa 251:677f6a0ee643
99 static Lisp_Object current_menudesc; 99 static Lisp_Object current_menudesc;
100 100
101 /* Current menubar or popup hashtable. gcpro'ed */ 101 /* Current menubar or popup hashtable. gcpro'ed */
102 static Lisp_Object current_hashtable; 102 static Lisp_Object current_hashtable;
103 103
104 /* Bound by menubar.el */
105 static Lisp_Object Qfind_menu_item;
106
107 /* This is used to allocate unique ids to menu items. 104 /* This is used to allocate unique ids to menu items.
108 Items ids are in MENU_ITEM_ID_MIN to MENU_ITEM_ID_MAX. 105 Items ids are in MENU_ITEM_ID_MIN to MENU_ITEM_ID_MAX.
109 Allocation checks that the item is not already in 106 Allocation checks that the item is not already in
110 the TOP_LEVEL_MENU */ 107 the TOP_LEVEL_MENU */
111 /* #### defines go to gui-msw.h */ 108
109 /* #### defines go to gui-msw.h, as the range is shared with toolbars
110 (If only toolbars will be implemented as common controls) */
112 #define MENU_ITEM_ID_MIN 0x8000 111 #define MENU_ITEM_ID_MIN 0x8000
113 #define MENU_ITEM_ID_MAX 0xFFFF 112 #define MENU_ITEM_ID_MAX 0xFFFF
114 #define MENU_ITEM_ID_BITS(x) ((x) & 0x7FFF | 0x8000) 113 #define MENU_ITEM_ID_BITS(x) ((x) & 0x7FFF | 0x8000)
115 static HMENU top_level_menu; 114 static HMENU top_level_menu;
116 115
117 /* ============= THIS STUFF MIGHT GO SOMEWHERE ELSE ================= */
118
119 /* All these functions are windows sys independent, and are candidates
120 to go to lisp code instead */
121
122 /*
123 * DESCRIPTOR is a list in the form ({:keyword value}+ rest...).
124 * This function extracts all the key-value pairs into the newly
125 * created plist, and returns pointer to REST. Original list is not
126 * modified (heaven save!)
127 */
128 Lisp_Object
129 gui_parse_menu_keywords (Lisp_Object descriptor, Lisp_Object *plist)
130 {
131 Lisp_Object pair, key, val;
132 *plist = Qnil;
133 LIST_LOOP (pair, descriptor)
134 {
135 if (!CONSP(pair))
136 signal_simple_error ("Mailformed gui entity descriptor", descriptor);
137 key = XCAR(pair);
138 if (!KEYWORDP (key))
139 return pair;
140 pair = XCDR (pair);
141 if (!CONSP(pair))
142 signal_simple_error ("Mailformed gui entity descriptor", descriptor);
143 val = XCAR (pair);
144 internal_plist_put (plist, key, val);
145 }
146 return pair;
147 }
148
149 /*
150 * DESC is a vector describing a menu item. The function returns menu
151 * item name in NAME, callback form in CALLBACK, and all key-values
152 * pairs in PLIST. For old-style vectors, the plist is faked.
153 */
154 void
155 gui_parse_button_descriptor (Lisp_Object desc, Lisp_Object *name,
156 Lisp_Object *callback, Lisp_Object *plist)
157 {
158 int length = XVECTOR_LENGTH (desc);
159 Lisp_Object *contents = XVECTOR_DATA (desc);
160 int plist_p;
161
162 *name = Qnil;
163 *callback = Qnil;
164 *plist = Qnil;
165
166 if (length < 3)
167 signal_simple_error ("Button descriptors must be at least 3 long", desc);
168
169 /* length 3: [ "name" callback active-p ]
170 length 4: [ "name" callback active-p suffix ]
171 or [ "name" callback keyword value ]
172 length 5+: [ "name" callback [ keyword value ]+ ]
173 */
174 plist_p = (length >= 5 || KEYWORDP (contents [2]));
175
176 *name = contents [0];
177 *callback = contents [1];
178
179 if (!plist_p)
180 /* the old way */
181 {
182 internal_plist_put (plist, Q_active, contents [2]);
183 if (length == 4)
184 internal_plist_put (plist, Q_suffix, contents [3]);
185 }
186 else
187 /* the new way */
188 {
189 int i;
190 if (length & 1)
191 signal_simple_error (
192 "Button descriptor has an odd number of keywords and values",
193 desc);
194
195 for (i = 2; i < length;)
196 {
197 Lisp_Object key = contents [i++];
198 Lisp_Object val = contents [i++];
199 if (!KEYWORDP (key))
200 signal_simple_error_2 ("Not a keyword", key, desc);
201 internal_plist_put (plist, key, val);
202 }
203 }
204 }
205
206 /*
207 * Given PLIST of key-value pairs for a menu item or button, consult
208 * :included and :config properties (the latter against
209 * CONFLIST). Return value is non-zero when item should *not* appear.
210 */
211 int
212 gui_plist_says_item_excluded (Lisp_Object plist, Lisp_Object conflist)
213 {
214 Lisp_Object tem;
215 /* This function can call lisp */
216
217 /* Evaluate :included first */
218 tem = internal_plist_get (plist, Q_included);
219 if (!UNBOUNDP (tem))
220 {
221 tem = Feval (tem);
222 if (NILP (tem))
223 return 1;
224 }
225
226 /* Do :config if conflist is given */
227 if (!NILP (conflist))
228 {
229 tem = internal_plist_get (plist, Q_config);
230 if (!UNBOUNDP (tem))
231 {
232 tem = Fmemq (tem, conflist);
233 if (NILP (tem))
234 return 1;
235 }
236 }
237
238 return 0;
239 }
240
241 /*
242 * Given PLIST of key-value pairs for a menu item or button, consult
243 * :active property. Return non-zero if the item is *inactive*
244 */
245 int
246 gui_plist_says_item_inactive (Lisp_Object plist)
247 {
248 Lisp_Object tem;
249 /* This function can call lisp */
250
251 tem = internal_plist_get (plist, Q_active);
252 if (!UNBOUNDP (tem))
253 {
254 tem = Feval (tem);
255 if (NILP (tem))
256 return 1;
257 }
258
259 return 0;
260 }
261
262 /*
263 * Given PLIST of key-value pairs for a menu item or button, evaluate
264 * the form which is the value of :filter property. Filter function
265 * given DESC as argument. If there's no :filter property, DESC is
266 * returned, otherwise the value returned by the filter function is
267 * returned.
268 */
269 Lisp_Object
270 gui_plist_apply_filter (Lisp_Object plist, Lisp_Object desc)
271 {
272 Lisp_Object tem;
273 /* This function can call lisp */
274
275 tem = internal_plist_get (plist, Q_filter);
276 if (UNBOUNDP (tem))
277 return desc;
278 else
279 return call1 (tem, desc);
280 }
281
282 /*
283 * This is tricky because there's no menu item styles in Windows, only
284 * states: Each item may be given no checkmark, radio or check
285 * mark. This function returns required mark style as determined by
286 * PLIST. Return value is the value of :style property if the item is
287 * :seleted, or nil otherwise
288 */
289 Lisp_Object
290 gui_plist_get_current_style (Lisp_Object plist)
291 {
292 Lisp_Object style, selected;
293 style = internal_plist_get (plist, Q_style);
294 if (UNBOUNDP (style) || NILP(style))
295 return Qnil;
296
297 selected = internal_plist_get (plist, Q_selected);
298 if (UNBOUNDP (selected) || NILP(Feval(selected)))
299 return Qnil;
300
301 return style;
302 }
303
304 Lisp_Object
305 current_frame_menubar (CONST struct frame* f)
306 {
307 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
308 return symbol_value_in_buffer (Qcurrent_menubar, w->buffer);
309 }
310
311 /* ============ END IF STUFF THAT MIGHT GO SOMEWHERE ELSE =============== */
312
313 /* Change these together */
314 #define MAX_MENUITEM_LENGTH 128 116 #define MAX_MENUITEM_LENGTH 128
315 #define DISPLAYABLE_MAX_MENUITEM_LENGTH "128" 117
316
317 static void
318 signal_item_too_long (Lisp_Object name)
319 {
320 signal_simple_error ("Menu item is longer than "
321 DISPLAYABLE_MAX_MENUITEM_LENGTH
322 " characters", name);
323 }
324
325 /* #### If this function returned (FLUSHLEFT . FLUSHRIGHT) it also
326 could be moved above that line - it becomes window system
327 independant */
328 /* 118 /*
329 * This returns Windows-style menu item string: 119 * This returns Windows-style menu item string:
330 * "Left Flush\tRight Flush" 120 * "Left Flush\tRight Flush"
331 */ 121 */
332 static CONST char* 122 static char*
333 plist_get_menu_item_name (Lisp_Object name, Lisp_Object callback, Lisp_Object plist) 123 displayable_menu_item (struct gui_item* pgui_item)
334 { 124 {
335 /* We construct the name in a static buffer. That's fine, beause 125 /* We construct the name in a static buffer. That's fine, beause
336 menu items longer than 128 chars are probably programming errors, 126 menu items longer than 128 chars are probably programming errors,
337 and better be caught than displayed! */ 127 and better be caught than displayed! */
338 128
339 static char buf[MAX_MENUITEM_LENGTH]; 129 static char buf[MAX_MENUITEM_LENGTH+2];
340 char* p = buf; 130 unsigned int ll, lr;
341 int buf_left = MAX_MENUITEM_LENGTH - 1; 131
342 Lisp_Object tem; 132 /* Left flush part of the string */
343 133 ll = gui_item_display_flush_left (pgui_item, buf, MAX_MENUITEM_LENGTH);
344 /* Get name first */ 134
345 buf_left -= XSTRING_LENGTH (name); 135 /* Right flush part */
346 if (buf_left < 0) 136 assert (MAX_MENUITEM_LENGTH > ll + 1);
347 signal_item_too_long (name); 137 lr = gui_item_display_flush_right (pgui_item, buf + ll + 1,
348 strcpy (p, XSTRING_DATA (name)); 138 MAX_MENUITEM_LENGTH - ll - 1);
349 p += XSTRING_LENGTH (name); 139 if (lr)
350 140 buf [ll] = '\t';
351 /* Have suffix? */ 141
352 tem = internal_plist_get (plist, Q_suffix);
353 if (!UNBOUNDP (tem))
354 {
355 if (!STRINGP (tem))
356 signal_simple_error (":suffix must be a string", tem);
357 buf_left -= XSTRING_LENGTH (tem) + 1;
358 if (buf_left < 0)
359 signal_item_too_long (name);
360 *p++ = ' ';
361 strcpy (p, XSTRING_DATA (tem));
362 p += XSTRING_LENGTH (tem);
363 }
364
365 /* Have keys? */
366 if (menubar_show_keybindings)
367 {
368 static char buf2 [1024];
369 buf2[0] = 0;
370
371 tem = internal_plist_get (plist, Q_keys);
372 if (!UNBOUNDP (tem))
373 {
374 if (!STRINGP (tem))
375 signal_simple_error (":keys must be a string", tem);
376 if (XSTRING_LENGTH (tem) > sizeof (buf2) - 1)
377 signal_item_too_long (name);
378 strcpy (buf2, XSTRING_DATA (tem));
379 }
380 else if (SYMBOLP (callback))
381 {
382 /* #### Warning, dependency here on current_buffer and point */
383 /* #### I've borrowed this warning along with this code from
384 menubar-x.c. What does that mean? -- kkm */
385 where_is_to_char (callback, buf2);
386 }
387
388 if (buf2 [0])
389 {
390 int n = strlen (buf2) + 1;
391 buf_left -= n;
392 if (buf_left < 0)
393 signal_item_too_long (name);
394 *p++ = '\t';
395 strcpy (p, buf2);
396 p += n-1;
397 }
398 }
399
400 *p = 0;
401 return buf; 142 return buf;
402 } 143 }
403 144
404 /* 145 /*
405 * hmenu_to_lisp_object() returns an opaque ptr given menu handle. 146 * hmenu_to_lisp_object() returns an opaque ptr given menu handle.
414 * Allocation tries a hash based on item's path and name first. This 155 * Allocation tries a hash based on item's path and name first. This
415 * almost guarantees that the same item will override its old value in 156 * almost guarantees that the same item will override its old value in
416 * the hashtable rather than abandon it. 157 * the hashtable rather than abandon it.
417 */ 158 */
418 static Lisp_Object 159 static Lisp_Object
419 allocate_menu_item_id (Lisp_Object path, Lisp_Object name) 160 allocate_menu_item_id (Lisp_Object path, Lisp_Object name, Lisp_Object suffix)
420 { 161 {
421 UINT id = MENU_ITEM_ID_BITS (HASH2 (internal_hash (path, 0), 162 UINT id = MENU_ITEM_ID_BITS (HASH3 (internal_hash (path, 0),
422 internal_hash (name, 0))); 163 internal_hash (name, 0),
164 internal_hash (suffix, 0)));
423 do { 165 do {
424 id = MENU_ITEM_ID_BITS (id + 1); 166 id = MENU_ITEM_ID_BITS (id + 1);
425 } while (GetMenuState (top_level_menu, id, MF_BYCOMMAND) != 0xFFFFFFFF); 167 } while (GetMenuState (top_level_menu, id, MF_BYCOMMAND) != 0xFFFFFFFF);
426 return make_int (id); 168 return make_int (id);
427 } 169 }
428 170
429 static HMENU 171 static HMENU
430 create_empty_popup_menu (void) 172 create_empty_popup_menu (void)
431 { 173 {
432 HMENU submenu = CreatePopupMenu (); 174 return CreatePopupMenu ();
433 /* #### It seems that really we do not need "(empty)" at this stage */
434 #if 0
435 AppendMenu (submenu, MF_STRING | MF_GRAYED, EMPTY_ITEM_ID, EMPTY_ITEM_NAME);
436 #endif
437 return submenu;
438 } 175 }
439 176
440 static void 177 static void
441 empty_menu (HMENU menu, int add_empty_p) 178 empty_menu (HMENU menu, int add_empty_p)
442 { 179 {
471 return internal_hash (XCAR(item), 0); 208 return internal_hash (XCAR(item), 0);
472 } 209 }
473 else if (VECTORP (item)) 210 else if (VECTORP (item))
474 { 211 {
475 /* An ordinary item - hash its name and callback form. */ 212 /* An ordinary item - hash its name and callback form. */
476 Lisp_Object plist, name, callback; 213 return HASH2 (internal_hash (XVECTOR_DATA(item)[0], 0),
477 gui_parse_button_descriptor (item, &name, &callback, &plist); 214 internal_hash (XVECTOR_DATA(item)[1], 0));
478 return HASH2 (internal_hash (name, 0),
479 internal_hash (callback, 0));
480 } 215 }
481 216
482 /* An error - will be caught later */ 217 /* An error - will be caught later */
483 return 0; 218 return 0;
484 } 219 }
486 static void 221 static void
487 populate_menu_add_item (HMENU menu, Lisp_Object path, 222 populate_menu_add_item (HMENU menu, Lisp_Object path,
488 Lisp_Object hash_tab, Lisp_Object item, int flush_right) 223 Lisp_Object hash_tab, Lisp_Object item, int flush_right)
489 { 224 {
490 MENUITEMINFO item_info; 225 MENUITEMINFO item_info;
491 struct gcpro gcpro1, gcpro2;
492 226
493 item_info.cbSize = sizeof (item_info); 227 item_info.cbSize = sizeof (item_info);
494 item_info.fMask = MIIM_TYPE | MIIM_STATE | MIIM_ID; 228 item_info.fMask = MIIM_TYPE | MIIM_STATE | MIIM_ID;
495 item_info.fState = 0; 229 item_info.fState = 0;
496 item_info.wID = 0; 230 item_info.wID = 0;
509 } 243 }
510 } 244 }
511 else if (CONSP (item)) 245 else if (CONSP (item))
512 { 246 {
513 /* Submenu */ 247 /* Submenu */
514 Lisp_Object subname = XCAR (item);
515 Lisp_Object plist;
516 HMENU submenu; 248 HMENU submenu;
517 249 struct gui_item gui_item;
518 if (!STRINGP (subname)) 250 struct gcpro gcpro1;
251
252 gui_item_init (&gui_item);
253 GCPRO1 (gui_item);
254 gcpro1.nvars = GUI_ITEM_GCPRO_COUNT;
255
256 menu_parse_submenu_keywords (item, &gui_item);
257
258 if (!STRINGP (gui_item.name))
519 signal_simple_error ("Menu name (first element) must be a string", item); 259 signal_simple_error ("Menu name (first element) must be a string", item);
520 260
521 item = gui_parse_menu_keywords (XCDR (item), &plist); 261 if (!gui_item_included_p (&gui_item, Vmenubar_configuration))
522 GCPRO1 (plist);
523
524 if (gui_plist_says_item_excluded (plist, Vmenubar_configuration))
525 return; 262 return;
526 263
527 if (gui_plist_says_item_inactive (plist)) 264 if (!gui_item_active_p (&gui_item))
528 item_info.fState = MFS_GRAYED; 265 item_info.fState = MFS_GRAYED;
529 /* Temptation is to put 'else' right here. Although, the 266 /* Temptation is to put 'else' right here. Although, the
530 displayed item won't have an arrow indicating that it is a 267 displayed item won't have an arrow indicating that it is a
531 popup. So we go ahead a little bit more and create a popup */ 268 popup. So we go ahead a little bit more and create a popup */
532 submenu = create_empty_popup_menu(); 269 submenu = create_empty_popup_menu();
533 270
534 item_info.fMask |= MIIM_SUBMENU; 271 item_info.fMask |= MIIM_SUBMENU;
535 item_info.dwTypeData = plist_get_menu_item_name (subname, Qnil, plist); 272 item_info.dwTypeData = displayable_menu_item (&gui_item);
536 item_info.hSubMenu = submenu; 273 item_info.hSubMenu = submenu;
537
538 UNGCPRO; /* plist */
539 274
540 if (!(item_info.fState & MFS_GRAYED)) 275 if (!(item_info.fState & MFS_GRAYED))
541 { 276 {
542 /* Now add the full submenu path as a value to the hash table, 277 /* Now add the full submenu path as a value to the hash table,
543 keyed by menu handle */ 278 keyed by menu handle */
544 if (NILP(path)) 279 if (NILP(path))
545 path = list1 (subname); 280 /* list1 cannot GC */
546 else { 281 path = list1 (gui_item.name);
547 Lisp_Object arg[2]; 282 else
548 arg[0] = path; 283 {
549 arg[1] = list1 (subname); 284 Lisp_Object arg[2] = { path, list1 (gui_item.name) };
550 GCPRO1 (arg[1]); 285 /* Fappend gcpro'es its arg */
551 path = Fappend (2, arg); 286 path = Fappend (2, arg);
552 UNGCPRO; /* arg[1] */ 287 }
553 } 288
554 289 /* Fputhash GCPRO'es PATH */
555 GCPRO1 (path);
556 Fputhash (hmenu_to_lisp_object (submenu), path, hash_tab); 290 Fputhash (hmenu_to_lisp_object (submenu), path, hash_tab);
557 UNGCPRO; /* path */
558 } 291 }
292 UNGCPRO; /* gui_item */
559 } 293 }
560 else if (VECTORP (item)) 294 else if (VECTORP (item))
561 { 295 {
562 /* An ordinary item */ 296 /* An ordinary item */
563 Lisp_Object plist, name, callback, style, id; 297 Lisp_Object style, id;
564 298 struct gui_item gui_item;
565 gui_parse_button_descriptor (item, &name, &callback, &plist); 299 struct gcpro gcpro1;
566 GCPRO2 (plist, callback); 300
567 301 gui_item_init (&gui_item);
568 if (gui_plist_says_item_excluded (plist, Vmenubar_configuration)) 302 GCPRO1 (gui_item);
303 gcpro1.nvars = GUI_ITEM_GCPRO_COUNT;
304
305 gui_parse_item_keywords (item, &gui_item);
306
307 if (!gui_item_included_p (&gui_item, Vmenubar_configuration))
569 return; 308 return;
570 309
571 if (gui_plist_says_item_inactive (plist)) 310 if (!gui_item_active_p (&gui_item))
572 item_info.fState |= MFS_GRAYED; 311 item_info.fState = MFS_GRAYED;
573 312
574 style = gui_plist_get_current_style (plist); 313 style = (NILP (gui_item.selected) || NILP (Feval (gui_item.selected))
314 ? Qnil : gui_item.style);
315
575 if (EQ (style, Qradio)) 316 if (EQ (style, Qradio))
576 { 317 {
577 item_info.fType |= MFT_RADIOCHECK; 318 item_info.fType |= MFT_RADIOCHECK;
578 item_info.fState |= MFS_CHECKED; 319 item_info.fState |= MFS_CHECKED;
579 } 320 }
580 else if (EQ (style, Qtoggle)) 321 else if (EQ (style, Qtoggle))
581 { 322 {
582 item_info.fState |= MFS_CHECKED; 323 item_info.fState |= MFS_CHECKED;
583 } 324 }
584 325
585 id = allocate_menu_item_id (path, name); 326 id = allocate_menu_item_id (path, gui_item.name,
586 Fputhash (id, callback, hash_tab); 327 gui_item.suffix);
587 328 Fputhash (id, gui_item.callback, hash_tab);
588 UNGCPRO; /* plist, callback */
589 329
590 item_info.wID = (UINT) XINT(id); 330 item_info.wID = (UINT) XINT(id);
591 item_info.fType |= MFT_STRING; 331 item_info.fType |= MFT_STRING;
592 item_info.dwTypeData = plist_get_menu_item_name (name, callback, plist); 332 item_info.dwTypeData = displayable_menu_item (&gui_item);
333
334 UNGCPRO; /* gui_item */
593 } 335 }
594 else 336 else
595 { 337 {
596 signal_simple_error ("Ill-constructed menu descriptor", item); 338 signal_simple_error ("Mailformed menu item descriptor", item);
597 } 339 }
598 340
599 if (flush_right) 341 if (flush_right)
600 item_info.fType |= MFT_RIGHTJUSTIFY; 342 item_info.fType |= MFT_RIGHTJUSTIFY;
601 343
612 * When called to checksum, DESCRIPTOR has the same meaning, POPULATE_P 354 * When called to checksum, DESCRIPTOR has the same meaning, POPULATE_P
613 * is zero, PATH must be Qnil, and the rest of parameters is ignored. 355 * is zero, PATH must be Qnil, and the rest of parameters is ignored.
614 * Return value is the menu checksum. 356 * Return value is the menu checksum.
615 */ 357 */
616 static unsigned long 358 static unsigned long
617 populate_or_checksum_helper (HMENU menu, Lisp_Object path, Lisp_Object descriptor, 359 populate_or_checksum_helper (HMENU menu, Lisp_Object path, Lisp_Object desc,
618 Lisp_Object hash_tab, int bar_p, int populate_p) 360 Lisp_Object hash_tab, int bar_p, int populate_p)
619 { 361 {
620 Lisp_Object menu_name, plist, item_desc; 362 Lisp_Object item_desc;
621 int deep_p, flush_right; 363 int deep_p, flush_right;
622 struct gcpro gcpro1; 364 struct gcpro gcpro1;
623 unsigned long checksum = 0; 365 unsigned long checksum = 0;
366 struct gui_item gui_item;
367
368 gui_item_init (&gui_item);
369 GCPRO1 (gui_item);
370 gcpro1.nvars = GUI_ITEM_GCPRO_COUNT;
624 371
625 /* Will initially contain only "(empty)" */ 372 /* Will initially contain only "(empty)" */
626 if (populate_p) 373 if (populate_p)
627 empty_menu (menu, 1); 374 empty_menu (menu, 1);
628 375
629 /* PATH set to nil indicates top-level popup or menubar */ 376 /* PATH set to nil indicates top-level popup or menubar */
630 deep_p = !NILP (path); 377 deep_p = !NILP (path);
631 378
632 if (!deep_p)
633 top_level_menu = menu;
634
635 if (!CONSP(descriptor))
636 signal_simple_error ("Menu descriptor must be a list", descriptor);
637
638 if (STRINGP (XCAR (descriptor)))
639 {
640 menu_name = XCAR (descriptor);
641 descriptor = XCDR (descriptor);
642 }
643 else
644 {
645 menu_name = Qnil;
646 if (deep_p) /* Not a popup or bar */
647 signal_simple_error ("Menu must have a name", descriptor);
648 }
649
650 /* Fetch keywords prepending the item list */ 379 /* Fetch keywords prepending the item list */
651 descriptor = gui_parse_menu_keywords (descriptor, &plist); 380 desc = menu_parse_submenu_keywords (desc, &gui_item);
652 GCPRO1 (plist); 381
653 descriptor = gui_plist_apply_filter (plist, descriptor); 382 /* Check that menu name is specified when expected */
654 UNGCPRO; /* plist */ 383 if (NILP (gui_item.name) && deep_p)
655 384 signal_simple_error ("Menu must have a name", desc);
656 /* Loop thru the descriptor's CDR and add items for each entry */ 385
386 /* Apply filter if specified */
387 if (!NILP (gui_item.filter))
388 desc = call1 (gui_item.filter, desc);
389
390 /* Loop thru the desc's CDR and add items for each entry */
657 flush_right = 0; 391 flush_right = 0;
658 EXTERNAL_LIST_LOOP (item_desc, descriptor) 392 EXTERNAL_LIST_LOOP (item_desc, desc)
659 { 393 {
660 if (NILP (XCAR (item_desc))) 394 if (NILP (XCAR (item_desc)))
661 { 395 {
662 if (bar_p) 396 if (bar_p)
663 flush_right = 1; 397 flush_right = 1;
679 RemoveMenu (menu, EMPTY_ITEM_ID, MF_BYCOMMAND); 413 RemoveMenu (menu, EMPTY_ITEM_ID, MF_BYCOMMAND);
680 414
681 /* Add the header to the popup, if told so. The same as in X - an 415 /* Add the header to the popup, if told so. The same as in X - an
682 insensitive item, and a separator (Seems to me, there were 416 insensitive item, and a separator (Seems to me, there were
683 two separators in X... In Windows this looks ugly, anywats. */ 417 two separators in X... In Windows this looks ugly, anywats. */
684 if (!bar_p && !deep_p && popup_menu_titles && !NILP(menu_name)) 418 if (!bar_p && !deep_p && popup_menu_titles && !NILP(gui_item.name))
685 { 419 {
420 CHECK_STRING (gui_item.name);
686 InsertMenu (menu, 0, MF_BYPOSITION | MF_STRING | MF_DISABLED, 421 InsertMenu (menu, 0, MF_BYPOSITION | MF_STRING | MF_DISABLED,
687 0, XSTRING_DATA(menu_name)); 422 0, XSTRING_DATA(gui_item.name));
688 InsertMenu (menu, 1, MF_BYPOSITION | MF_SEPARATOR, 0, NULL); 423 InsertMenu (menu, 1, MF_BYPOSITION | MF_SEPARATOR, 0, NULL);
689 SetMenuDefaultItem (menu, 0, MF_BYPOSITION); 424 SetMenuDefaultItem (menu, 0, MF_BYPOSITION);
690 } 425 }
691 } 426 }
427 UNGCPRO; /* gui_item */
692 return checksum; 428 return checksum;
693 } 429 }
694 430
695 static void 431 static void
696 populate_menu (HMENU menu, Lisp_Object path, Lisp_Object descriptor, 432 populate_menu (HMENU menu, Lisp_Object path, Lisp_Object desc,
697 Lisp_Object hash_tab, int bar_p) 433 Lisp_Object hash_tab, int bar_p)
698 { 434 {
699 populate_or_checksum_helper (menu, path, descriptor, hash_tab, bar_p, 1); 435 populate_or_checksum_helper (menu, path, desc, hash_tab, bar_p, 1);
700 } 436 }
701 437
702 static unsigned long 438 static unsigned long
703 checksum_menu (Lisp_Object descriptor) 439 checksum_menu (Lisp_Object desc)
704 { 440 {
705 return populate_or_checksum_helper (NULL, Qnil, descriptor, Qunbound, 0, 0); 441 return populate_or_checksum_helper (NULL, Qnil, desc, Qunbound, 0, 0);
706 }
707
708 static Lisp_Object
709 find_menu (Lisp_Object desc, Lisp_Object path)
710 {
711 /* #### find-menu-item is not what's required here.
712 Need to write this in C, or improve lisp */
713 if (!NILP (path))
714 {
715 desc = call2 (Qfind_menu_item, desc, path);
716 /* desc is (supposed to be) (ITEM . PARENT). Supposed
717 to signal but sometimes manages to return nil */
718 if (!NILP(desc))
719 {
720 CHECK_CONS (desc);
721 desc = XCAR (desc);
722 }
723 }
724 return desc;
725 } 442 }
726 443
727 static void 444 static void
728 update_frame_menubar_maybe (struct frame* f) 445 update_frame_menubar_maybe (struct frame* f)
729 { 446 {
730 HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f)); 447 HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f));
731 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)); 448 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
732 Lisp_Object desc = (!NILP (w->menubar_visible_p) 449 Lisp_Object desc = (!NILP (w->menubar_visible_p)
733 ? symbol_value_in_buffer (Qcurrent_menubar, w->buffer) 450 ? symbol_value_in_buffer (Qcurrent_menubar, w->buffer)
734 : Qnil); 451 : Qnil);
452
453 top_level_menu = menubar;
735 454
736 if (NILP (desc) && menubar != NULL) 455 if (NILP (desc) && menubar != NULL)
737 { 456 {
738 /* Menubar has gone */ 457 /* Menubar has gone */
739 FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil; 458 FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil;
840 error ("internal menu error"); 559 error ("internal menu error");
841 #endif 560 #endif
842 561
843 /* Now find a desc chunk for it. If none, then probably menu open 562 /* Now find a desc chunk for it. If none, then probably menu open
844 hook has played too much games around stuff */ 563 hook has played too much games around stuff */
845 desc = current_menudesc; 564 desc = Fmenu_find_real_submenu (current_menudesc, path);
846 if (!NILP (path)) 565 if (NILP (desc))
847 { 566 signal_simple_error ("This menu does not exist any more", path);
848 desc = find_menu (desc, path);
849 if (NILP (desc))
850 signal_simple_error ("This menu does not exist any more", path);
851 }
852 567
853 /* Now, stuff it */ 568 /* Now, stuff it */
854 /* DESC may be generated by filter, so we have to gcpro it */ 569 /* DESC may be generated by filter, so we have to gcpro it */
855 GCPRO1 (desc); 570 GCPRO1 (desc);
856 populate_menu (menu, path, desc, current_hashtable, 0); 571 populate_menu (menu, path, desc, current_hashtable, 0);
860 575
861 static Lisp_Object 576 static Lisp_Object
862 unsafe_handle_wm_initmenu_1 (struct frame* f) 577 unsafe_handle_wm_initmenu_1 (struct frame* f)
863 { 578 {
864 /* This function can call lisp */ 579 /* This function can call lisp */
580
581 /* NOTE: This is called for the bar only, WM_INITMENU
582 for popups is filtered out */
583
865 /* #### - this menubar update mechanism is expensively anti-social and 584 /* #### - this menubar update mechanism is expensively anti-social and
866 the activate-menubar-hook is now mostly obsolete. */ 585 the activate-menubar-hook is now mostly obsolete. */
867 586
868 /* We simply ignore return value. In any case, we construct the bar 587 /* We simply ignore return value. In any case, we construct the bar
869 on the fly */ 588 on the fly */
875 current_hashtable = FRAME_MSWINDOWS_MENU_HASHTABLE(f); 594 current_hashtable = FRAME_MSWINDOWS_MENU_HASHTABLE(f);
876 assert (HASHTABLEP (current_hashtable)); 595 assert (HASHTABLEP (current_hashtable));
877 596
878 return Qt; 597 return Qt;
879 } 598 }
880
881 #ifdef KKM_DOES_NOT_LIKE_UNDOCS_SOMETIMES
882
883 /* #### This may become wrong in future Windows */
884
885 static Lisp_Object
886 unsafe_handle_wm_exitmenuloop_1 (struct frame* f)
887 {
888 if (!NILP (current_tracking_popup))
889 prune_menubar (f);
890 return Qt;
891 }
892
893 #endif
894 599
895 /* 600 /*
896 * Return value is Qt if we have dispatched the command, 601 * Return value is Qt if we have dispatched the command,
897 * or Qnil if id has not been mapped to a callback. 602 * or Qnil if id has not been mapped to a callback.
898 * Window procedure may try other targets to route the 603 * Window procedure may try other targets to route the
922 if (SYMBOLP (command)) 627 if (SYMBOLP (command))
923 funcsym = Qcall_interactively; 628 funcsym = Qcall_interactively;
924 else if (CONSP (command)) 629 else if (CONSP (command))
925 funcsym = Qeval; 630 funcsym = Qeval;
926 else 631 else
927 signal_simple_error ("Illegal callback", command); 632 signal_simple_error ("Callback must be either evallable form or a symbol",
633 command);
928 634
929 XSETFRAME (frame, f); 635 XSETFRAME (frame, f);
930 enqueue_misc_user_event (frame, funcsym, command); 636 enqueue_misc_user_event (frame, funcsym, command);
931 637
932 /* Needs good bump also, for WM_COMMAND may have been dispatched from 638 /* Needs good bump also, for WM_COMMAND may have been dispatched from
957 unsafe_handle_wm_initmenu (Lisp_Object u_n_u_s_e_d) 663 unsafe_handle_wm_initmenu (Lisp_Object u_n_u_s_e_d)
958 { 664 {
959 return unsafe_handle_wm_initmenu_1 (wm_initmenu_frame); 665 return unsafe_handle_wm_initmenu_1 (wm_initmenu_frame);
960 } 666 }
961 667
962 #ifdef KKM_DOES_NOT_LIKE_UNDOCS_SOMETIMES
963 static Lisp_Object
964 unsafe_handle_wm_exitmenuloop (Lisp_Object u_n_u_s_e_d)
965 {
966 return unsafe_handle_wm_exitmenuloop_1 (wm_initmenu_frame);
967 }
968 #endif
969
970 Lisp_Object 668 Lisp_Object
971 mswindows_handle_wm_initmenupopup (HMENU hmenu, struct frame* frm) 669 mswindows_handle_wm_initmenupopup (HMENU hmenu, struct frame* frm)
972 { 670 {
973 /* We cannot pass hmenu as a lisp object. Use static var */ 671 /* We cannot pass hmenu as a lisp object. Use static var */
974 wm_initmenu_menu = hmenu; 672 wm_initmenu_menu = hmenu;
986 return mswindows_protect_modal_loop (unsafe_handle_wm_initmenu, Qnil); 684 return mswindows_protect_modal_loop (unsafe_handle_wm_initmenu, Qnil);
987 } 685 }
988 return Qt; 686 return Qt;
989 } 687 }
990 688
689 /* #### This function goes away. Removing it now may
690 interfere with pending patch 980128-jhar */
991 Lisp_Object 691 Lisp_Object
992 mswindows_handle_wm_exitmenuloop (struct frame* f) 692 mswindows_handle_wm_exitmenuloop (struct frame* f)
993 { 693 {
994 #ifdef KKM_DOES_NOT_LIKE_UNDOCS_SOMETIMES
995 wm_initmenu_frame = f;
996 return mswindows_protect_modal_loop (unsafe_handle_wm_exitmenuloop, Qnil);
997 #else
998 return Qt; 694 return Qt;
999 #endif
1000 } 695 }
1001 696
1002 697
1003 /*------------------------------------------------------------------------*/ 698 /*------------------------------------------------------------------------*/
1004 /* Methods */ 699 /* Methods */
1005 /*------------------------------------------------------------------------*/ 700 /*------------------------------------------------------------------------*/
1006 701
1007 static void 702 static void
1008 mswindows_update_frame_menubars (struct frame* f) 703 mswindows_update_frame_menubars (struct frame* f)
1009 { 704 {
1010 update_frame_menubar_maybe (f); 705 /* #### KLUDGE. menubar.c calls us when the following
706 condition is true:
707 (f->menubar_changed || f->windows_changed)
708 Is that much really necessary?
709 */
710 if (f->menubar_changed)
711 update_frame_menubar_maybe (f);
1011 } 712 }
1012 713
1013 static void 714 static void
1014 mswindows_free_frame_menubars (struct frame* f) 715 mswindows_free_frame_menubars (struct frame* f)
1015 { 716 {
1058 759
1059 current_menudesc = menu_desc; 760 current_menudesc = menu_desc;
1060 current_hashtable = Fmake_hashtable (make_int(10), Qequal); 761 current_hashtable = Fmake_hashtable (make_int(10), Qequal);
1061 menu = create_empty_popup_menu(); 762 menu = create_empty_popup_menu();
1062 Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hashtable); 763 Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hashtable);
764 top_level_menu = menu;
1063 765
1064 ok = TrackPopupMenu (menu, 766 ok = TrackPopupMenu (menu,
1065 TPM_LEFTALIGN | TPM_LEFTBUTTON | TPM_RIGHTBUTTON, 767 TPM_LEFTALIGN | TPM_LEFTBUTTON | TPM_RIGHTBUTTON,
1066 pt.x, pt.y, 0, 768 pt.x, pt.y, 0,
1067 FRAME_MSWINDOWS_HANDLE (f), NULL); 769 FRAME_MSWINDOWS_HANDLE (f), NULL);
1084 /* Initialization */ 786 /* Initialization */
1085 /*------------------------------------------------------------------------*/ 787 /*------------------------------------------------------------------------*/
1086 void 788 void
1087 syms_of_menubar_mswindows (void) 789 syms_of_menubar_mswindows (void)
1088 { 790 {
1089 defsymbol (&Qfind_menu_item, "find-menu-item");
1090 } 791 }
1091 792
1092 void 793 void
1093 console_type_create_menubar_mswindows (void) 794 console_type_create_menubar_mswindows (void)
1094 { 795 {
1104 current_hashtable = Qnil; 805 current_hashtable = Qnil;
1105 806
1106 staticpro (&current_menudesc); 807 staticpro (&current_menudesc);
1107 staticpro (&current_hashtable); 808 staticpro (&current_hashtable);
1108 809
1109 Fprovide (intern ("mswindows-menubars"));
1110 }