Mercurial > hg > xemacs-beta

comparison src/menubar-msw.c @ 231:557eaa0339bf r20-5b14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b14
author cvs
date Mon, 13 Aug 2007 10:13:48 +0200
parents
children 52952cbfc5b5
comparison
equal deleted inserted replaced
230:39ed1d2bdd9d 231:557eaa0339bf
1 /* Implements an elisp-programmable menubar -- Win32
2 Copyright (C) 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
4 Copyright (C) 1997 Kirill M. Katsnelson <kkm@kis.ru>
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
22
23 /* Synched up with: Not in FSF. */
24
25 /* Autorship:
26 Initially written by kkm 12/24/97,
27 peeking into and copying stuff from menubar-x.c
28 */
29
30 /* Algotirhm for handling menus is as follows. When window's menubar
31 * is created, current-menubar is not traversed in depth. Rather, only
32 * top level items, both items and pulldowns, are added to the
33 * menubar. Each pulldown is initially empty. When a pulldown is
34 * selected and about to open, corresponding element of
35 * current-menubar is found, and the newly open pulldown is
36 * populated. This is made again in the same non-recursive manner.
37 *
38 * This algorithm uses hash tables to find out element of the menu
39 * descriptor list given menu handle. The key is an opaque ptr data
40 * type, keeping menu handle, and the value is a list of strings
41 * representing the path from the root of the menu to the item
42 * descriptor. Each frame has an associated hashtable.
43 *
44 * Leaf items are assigned a unique id based on item's hash. When an
45 * item is selected, Windows sends back the id. Unfortunately, only
46 * low 16 bit of the ID are sent, and there's no way to get the 32-bit
47 * value. Yes, Win32 is just a different set of bugs than X! Aside
48 * from this blame, another hasing mechanism is required to map menu
49 * ids to commands (which are actually Lisp_Object's). This mapping is
50 * performed in the same hashtable, as the lifetime of both maps is
51 * exactly the same. This is unabmigous, as menu handles are
52 * represented by lisp opaques, while command ids are by lisp
53 * integers. The additional advantage for this is that command forms
54 * are automatically GC-protected, which is important because these
55 * may be transient forms generated by :filter functions.
56 *
57 * The hashtable is not allowed to grow too much; it is pruned
58 * whenever this is safe to do. This is done by re-creating the menu
59 * bar, and clearing and refilling the hash table from scratch.
60 *
61 * Popup menus are handled identially to pulldowns. A static hash
62 * table is used for popup menus, and lookup is made not in
63 * current-menubar but in a lisp form supplied to the `popup'
64 * function.
65 *
66 * Another Windows weirdness is that there's no way to tell that a
67 * popup has been dismissed without making selection. We need to know
68 * that to cleanup the popup menu hashtable, but this is not honestly
69 * doable using *documented* sequence of messages. Sticking to
70 * particular knowledge is bad because this may break in Windows NT
71 * 5.0, or Windows 98, or other future version. Instead, I allow the
72 * hashtables to hang around, and not clear them, unless WM_COMMAND is
73 * received. This is worthy some memory but more safe. Hacks welcome,
74 * anyways!
75 *
76 */
77
78 #include <config.h>
79 #include "lisp.h"
80
81 #include "buffer.h"
82 #include "commands.h"
83 #include "console-msw.h"
84 #include "emacsfns.h"
85 #include "elhash.h"
86 #include "event-msw.h"
87 #include "events.h"
88 #include "frame.h"
89 #include "gui.h"
90 #include "lisp.h"
91 #include "menubar.h"
92 #include "menubar-msw.h"
93 #include "opaque.h"
94 #include "window.h"
95
96 #define EMPTY_ITEM_ID ((UINT)LISP_TO_VOID (Qunbound))
97 #define EMPTY_ITEM_NAME "(empty)"
98
99 /* Qnil when there's no popup being tracked, or a descriptor
100 for the popup. gcpro'ed */
101 static Lisp_Object current_tracking_popup;
102
103 /* Current popup has table. Qnil when no popup. gcpro'ed */
104 static Lisp_Object current_popup_hash_table;
105
106 /* Bound by menubar.el */
107 static Lisp_Object Qfind_menu_item;
108
109 /* This is used to allocate unique ids to menu items.
110 Items ids are in MENU_ITEM_ID_MIN to MENU_ITEM_ID_MAX.
111 Allocation checks that the item is not already in
112 the TOP_LEVEL_MENU */
113 /* #### defines go to gui-msw.h */
114 #define MENU_ITEM_ID_MIN 0x8000
115 #define MENU_ITEM_ID_MAX 0xFFFF
116 #define MENU_ITEM_ID_BITS(x) ((x) & 0x7FFF | 0x8000)
117 static HMENU top_level_menu;
118
119 /* ============= THIS STUFF MIGHT GO SOMEWHERE ELSE ================= */
120
121 /* All these functions are windows sys independent, and are candidates
122 to go to lisp code instead */
123
124 /*
125 * DESCRIPTOR is a list in the form ({:keyword value}+ rest...).
126 * This function extracts all the key-value pairs into the newly
127 * created plist, and returns pointer to REST. Original list is not
128 * modified (heaven save!)
129 */
130 Lisp_Object
131 gui_parse_menu_keywords (Lisp_Object descriptor, Lisp_Object *plist)
132 {
133 Lisp_Object pair, key, val;
134 *plist = Qnil;
135 LIST_LOOP (pair, descriptor)
136 {
137 if (!CONSP(pair))
138 signal_simple_error ("Mailformed gui entity descriptor", descriptor);
139 key = XCAR(pair);
140 if (!KEYWORDP (key))
141 return pair;
142 pair = XCDR (pair);
143 if (!CONSP(pair))
144 signal_simple_error ("Mailformed gui entity descriptor", descriptor);
145 val = XCAR (pair);
146 internal_plist_put (plist, key, val);
147 }
148 return pair;
149 }
150
151 /*
152 * DESC is a vector describing a menu item. The function returns menu
153 * item name in NAME, callback form in CALLBACK, and all key-values
154 * pairs in PLIST. For old-style vectors, the plist is faked.
155 */
156 void
157 gui_parse_button_descriptor (Lisp_Object desc, Lisp_Object *name,
158 Lisp_Object *callback, Lisp_Object *plist)
159 {
160 int length = XVECTOR_LENGTH (desc);
161 Lisp_Object *contents = XVECTOR_DATA (desc);
162 int plist_p;
163
164 *name = Qnil;
165 *callback = Qnil;
166 *plist = Qnil;
167
168 if (length < 3)
169 signal_simple_error ("button descriptors must be at least 3 long", desc);
170
171 /* length 3: [ "name" callback active-p ]
172 length 4: [ "name" callback active-p suffix ]
173 or [ "name" callback keyword value ]
174 length 5+: [ "name" callback [ keyword value ]+ ]
175 */
176 plist_p = (length >= 5 || KEYWORDP (contents [2]));
177
178 *name = contents [0];
179 *callback = contents [1];
180
181 if (!plist_p)
182 /* the old way */
183 {
184 internal_plist_put (plist, Q_active, contents [2]);
185 if (length == 4)
186 internal_plist_put (plist, Q_suffix, contents [3]);
187 }
188 else
189 /* the new way */
190 {
191 int i;
192 if (length & 1)
193 signal_simple_error (
194 "button descriptor has an odd number of keywords and values",
195 desc);
196
197 for (i = 2; i < length;)
198 {
199 Lisp_Object key = contents [i++];
200 Lisp_Object val = contents [i++];
201 if (!KEYWORDP (key))
202 signal_simple_error_2 ("not a keyword", key, desc);
203 internal_plist_put (plist, key, val);
204 }
205 }
206 }
207
208 /*
209 * Given PLIST of key-value pairs for a menu item or button, consult
210 * :included and :config properties (the latter against
211 * CONFLIST). Return value is non-zero when item should *not* appear.
212 */
213 int
214 gui_plist_says_item_excluded (Lisp_Object plist, Lisp_Object conflist)
215 {
216 Lisp_Object tem;
217 /* This function can call lisp */
218
219 /* Evaluate :included first */
220 tem = internal_plist_get (plist, Q_included);
221 if (!UNBOUNDP (tem))
222 {
223 tem = Feval (tem);
224 if (NILP (tem))
225 return 1;
226 }
227
228 /* Do :config if conflist is given */
229 if (!NILP (conflist))
230 {
231 tem = internal_plist_get (plist, Q_config);
232 if (!UNBOUNDP (tem))
233 {
234 tem = Fmemq (tem, conflist);
235 if (NILP (tem))
236 return 1;
237 }
238 }
239
240 return 0;
241 }
242
243 /*
244 * Given PLIST of key-value pairs for a menu item or button, consult
245 * :active property. Return non-zero if the item is *inactive*
246 */
247 int
248 gui_plist_says_item_inactive (Lisp_Object plist)
249 {
250 Lisp_Object tem;
251 /* This function can call lisp */
252
253 tem = internal_plist_get (plist, Q_active);
254 if (!UNBOUNDP (tem))
255 {
256 tem = Feval (tem);
257 if (NILP (tem))
258 return 1;
259 }
260
261 return 0;
262 }
263
264 /*
265 * Given PLIST of key-value pairs for a menu item or button, evaluate
266 * the form which is the value of :filter property. Filter function
267 * given DESC as argument. If there's no :filter property, DESC is
268 * returned, otherwise the value returned by the filter function is
269 * returned.
270 */
271 Lisp_Object
272 gui_plist_apply_filter (Lisp_Object plist, Lisp_Object desc)
273 {
274 Lisp_Object tem;
275 /* This function can call lisp */
276
277 tem = internal_plist_get (plist, Q_filter);
278 if (UNBOUNDP (tem))
279 return desc;
280 else
281 return call1 (tem, desc);
282 }
283
284 /*
285 * This is tricky because there's no menu item styles in Windows, only
286 * states: Each item may be given no checkmark, radio or check
287 * mark. This function returns required mark style as determined by
288 * PLIST. Return value is the value of :style property if the item is
289 * :seleted, or nil otherwise
290 */
291 Lisp_Object
292 gui_plist_get_current_style (Lisp_Object plist)
293 {
294 Lisp_Object style, selected;
295 style = internal_plist_get (plist, Q_style);
296 if (UNBOUNDP (style) || NILP(style))
297 return Qnil;
298
299 selected = internal_plist_get (plist, Q_selected);
300 if (UNBOUNDP (selected) || NILP(Feval(selected)))
301 return Qnil;
302
303 return style;
304 }
305
306 Lisp_Object
307 current_frame_menubar (CONST struct frame* f)
308 {
309 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
310 return symbol_value_in_buffer (Qcurrent_menubar, w->buffer);
311 }
312
313 /* ============ END IF STUFF THAT MIGHT GO SOMEWHERE ELSE =============== */
314
315 /* Change these together */
316 #define MAX_MENUITEM_LENGTH 128
317 #define DISPLAYABLE_MAX_MENUITEM_LENGTH "128"
318
319 static void
320 signal_item_too_long (Lisp_Object name)
321 {
322 signal_simple_error ("Menu item is longer than "
323 DISPLAYABLE_MAX_MENUITEM_LENGTH
324 " characters", name);
325 }
326
327 /* #### If this function returned (FLUSHLEFT . FLUSHRIGHT) it also
328 could be moved above that line - it becomes window system
329 independant */
330 /*
331 * This returns Windows-style menu item string:
332 * "Left Flush\tRight Flush"
333 */
334 static CONST char*
335 plist_get_menu_item_name (Lisp_Object name, Lisp_Object callback, Lisp_Object plist)
336 {
337 /* We construct the name in a static buffer. That's fine, beause
338 menu items longer than 128 chars are probably programming errors,
339 and better be caught than displayed! */
340
341 static char buf[MAX_MENUITEM_LENGTH];
342 char* p = buf;
343 int buf_left = MAX_MENUITEM_LENGTH - 1;
344 Lisp_Object tem;
345
346 /* Get name first */
347 buf_left -= XSTRING_LENGTH (name);
348 if (buf_left < 0)
349 signal_item_too_long (name);
350 strcpy (p, XSTRING_DATA (name));
351 p += XSTRING_LENGTH (name);
352
353 /* Have suffix? */
354 tem = internal_plist_get (plist, Q_suffix);
355 if (!UNBOUNDP (tem))
356 {
357 if (!STRINGP (tem))
358 signal_simple_error (":suffix must be a string", tem);
359 buf_left -= XSTRING_LENGTH (tem) + 1;
360 if (buf_left < 0)
361 signal_item_too_long (name);
362 *p++ = ' ';
363 strcpy (p, XSTRING_DATA (tem));
364 p += XSTRING_LENGTH (tem);
365 }
366
367 /* Have keys? */
368 if (menubar_show_keybindings)
369 {
370 static char buf2 [1024];
371 buf2[0] = 0;
372
373 tem = internal_plist_get (plist, Q_keys);
374 if (!UNBOUNDP (tem))
375 {
376 if (!STRINGP (tem))
377 signal_simple_error (":keys must be a string", tem);
378 if (XSTRING_LENGTH (tem) > sizeof (buf2) - 1)
379 signal_item_too_long (name);
380 strcpy (buf2, XSTRING_DATA (tem));
381 }
382 else if (SYMBOLP (callback))
383 {
384 /* #### Warning, dependency here on current_buffer and point */
385 /* #### I've borrowed this warning along with this code from
386 menubar-x.c. What does that mean? -- kkm */
387 where_is_to_char (callback, buf2);
388 }
389
390 if (buf2 [0])
391 {
392 int n = strlen (buf2) + 1;
393 buf_left -= n;
394 if (buf_left < 0)
395 signal_item_too_long (name);
396 *p++ = '\t';
397 strcpy (p, buf2);
398 p += n-1;
399 }
400 }
401
402 *p = 0;
403 return buf;
404 }
405
406 /*
407 * hmenu_to_lisp_object() returns an opaque ptr given menu handle.
408 */
409 static Lisp_Object
410 hmenu_to_lisp_object (HMENU hmenu)
411 {
412 return make_opaque_ptr (hmenu);
413 }
414
415 /*
416 * Allocation tries a hash based on item's path and name first. This
417 * almost guarantees that the same item will override its old value in
418 * the hashtable rather than abandon it.
419 */
420 static Lisp_Object
421 allocate_menu_item_id (Lisp_Object path, Lisp_Object name)
422 {
423 UINT id = MENU_ITEM_ID_BITS (HASH2 (internal_hash (path, 0),
424 internal_hash (name, 0)));
425 do {
426 id = MENU_ITEM_ID_BITS (id + 1);
427 } while (GetMenuState (top_level_menu, id, MF_BYCOMMAND) != 0xFFFFFFFF);
428 return make_int (id);
429 }
430
431 static HMENU
432 create_empty_popup_menu (void)
433 {
434 HMENU submenu = CreatePopupMenu ();
435 /* #### It seems that really we do not need "(empty)" at this stage */
436 #if 0
437 AppendMenu (submenu, MF_STRING | MF_GRAYED, EMPTY_ITEM_ID, EMPTY_ITEM_NAME);
438 #endif
439 return submenu;
440 }
441
442 static void
443 empty_menu (HMENU menu, int add_empty_p)
444 {
445 while (DeleteMenu (menu, 0, MF_BYPOSITION));
446 if (add_empty_p)
447 AppendMenu (menu, MF_STRING | MF_GRAYED, EMPTY_ITEM_ID, EMPTY_ITEM_NAME);
448 }
449
450 static void
451 populate_menu_add_item (HMENU menu, Lisp_Object path,
452 Lisp_Object hash_tab, Lisp_Object item, int flush_right)
453 {
454 MENUITEMINFO item_info;
455 struct gcpro gcpro1, gcpro2;
456
457 item_info.cbSize = sizeof (item_info);
458 item_info.fMask = MIIM_TYPE | MIIM_STATE | MIIM_ID;
459 item_info.fState = 0;
460 item_info.wID = 0;
461 item_info.fType = 0;
462
463 if (STRINGP (item))
464 {
465 /* Separator or unselectable text */
466 if (separator_string_p (XSTRING_DATA (item)))
467 item_info.fType = MFT_SEPARATOR;
468 else
469 {
470 item_info.fType = MFT_STRING;
471 item_info.fState = MFS_DISABLED;
472 item_info.dwTypeData = XSTRING_DATA (item);
473 }
474 }
475 else if (CONSP (item))
476 {
477 /* Submenu */
478 Lisp_Object subname = XCAR (item);
479 Lisp_Object plist;
480 HMENU submenu;
481
482 if (!STRINGP (subname))
483 signal_simple_error ("menu name (first element) must be a string", item);
484
485 item = gui_parse_menu_keywords (XCDR (item), &plist);
486 GCPRO1 (plist);
487
488 if (gui_plist_says_item_excluded (plist, Vmenubar_configuration))
489 return;
490
491 if (gui_plist_says_item_inactive (plist))
492 item_info.fState = MFS_GRAYED;
493 /* Temptation is to put 'else' right here. Although, the
494 displayed item won't have an arrow indicating that it is a
495 popup. So we go ahead a little bit more and create a popup */
496 submenu = create_empty_popup_menu();
497
498 item_info.fMask |= MIIM_SUBMENU;
499 item_info.dwTypeData = plist_get_menu_item_name (subname, Qnil, plist);
500 item_info.hSubMenu = submenu;
501
502 UNGCPRO; /* plist */
503
504 if (!(item_info.fState & MFS_GRAYED))
505 {
506 /* Now add the full submenu path as a value to the hash table,
507 keyed by menu handle */
508 if (NILP(path))
509 path = list1 (subname);
510 else {
511 Lisp_Object arg[2];
512 arg[0] = path;
513 arg[1] = list1 (subname);
514 GCPRO1 (arg[1]);
515 path = Fappend (2, arg);
516 UNGCPRO; /* arg[1] */
517 }
518
519 GCPRO1 (path);
520 Fputhash (hmenu_to_lisp_object (submenu), path, hash_tab);
521 UNGCPRO; /* path */
522 }
523 }
524 else if (VECTORP (item))
525 {
526 /* An ordinary item */
527 Lisp_Object plist, name, callback, style, id;
528
529 gui_parse_button_descriptor (item, &name, &callback, &plist);
530 GCPRO2 (plist, callback);
531
532 if (gui_plist_says_item_excluded (plist, Vmenubar_configuration))
533 return;
534
535 if (gui_plist_says_item_inactive (plist))
536 item_info.fState |= MFS_GRAYED;
537
538 style = gui_plist_get_current_style (plist);
539 if (EQ (style, Qradio))
540 {
541 item_info.fType |= MFT_RADIOCHECK;
542 item_info.fState |= MFS_CHECKED;
543 }
544 else if (EQ (style, Qtoggle))
545 {
546 item_info.fState |= MFS_CHECKED;
547 }
548
549 id = allocate_menu_item_id (path, name);
550 Fputhash (id, callback, hash_tab);
551
552 UNGCPRO; /* plist, callback */
553
554 item_info.wID = (UINT) XINT(id);
555 item_info.fType |= MFT_STRING;
556 item_info.dwTypeData = plist_get_menu_item_name (name, callback, plist);
557 }
558 else
559 {
560 signal_simple_error ("ill-constructed menu descriptor", item);
561 }
562
563 if (flush_right)
564 item_info.fType |= MFT_RIGHTJUSTIFY;
565
566 InsertMenuItem (menu, UINT_MAX, TRUE, &item_info);
567 }
568
569 static void
570 populate_menu (HMENU menu, Lisp_Object path, Lisp_Object descriptor,
571 Lisp_Object hash_tab, int bar_p)
572 {
573 Lisp_Object menu_name, plist, item_desc;
574 int deep_p, flush_right;
575 struct gcpro gcpro1;
576
577 /* Will initially contain only "(empty)" */
578 empty_menu (menu, 1);
579
580 /* PATH set to nil indicates top-level popup or menubar */
581 deep_p = !NILP (path);
582
583 if (!deep_p)
584 top_level_menu = menu;
585
586 if (!CONSP(descriptor))
587 signal_simple_error ("menu descriptor must be a list", descriptor);
588
589 if (STRINGP (XCAR (descriptor)))
590 {
591 menu_name = XCAR (descriptor);
592 descriptor = XCDR (descriptor);
593 }
594 else
595 {
596 menu_name = Qnil;
597 if (deep_p) /* Not a popup or bar */
598 signal_simple_error ("menu must have a name", descriptor);
599 }
600
601 /* Fetch keywords prepending the item list */
602 descriptor = gui_parse_menu_keywords (descriptor, &plist);
603 GCPRO1 (plist);
604 descriptor = gui_plist_apply_filter (plist, descriptor);
605 UNGCPRO; /* plist */
606
607 /* Loop thru the descriptor's CDR and add items for each entry */
608 flush_right = 0;
609 EXTERNAL_LIST_LOOP (item_desc, descriptor)
610 {
611 if (NILP (XCAR (item_desc)))
612 {
613 if (bar_p)
614 flush_right = 1;
615 }
616 else
617 populate_menu_add_item (menu, path, hash_tab,
618 XCAR (item_desc), flush_right);
619 }
620
621 /* Remove the "(empty)" item, if there are other ones */
622 if (GetMenuItemCount (menu) > 1)
623 RemoveMenu (menu, EMPTY_ITEM_ID, MF_BYCOMMAND);
624
625 /* Add the header to the popup, if told so. The same as in X - an
626 insensitive item, and a separator (Seems to me, there were
627 two separators in X... In Windows this looks ugly, anywats. */
628 if (!bar_p && !deep_p && popup_menu_titles && !NILP(menu_name))
629 {
630 InsertMenu (menu, 0, MF_BYPOSITION | MF_STRING | MF_DISABLED,
631 0, XSTRING_DATA(menu_name));
632 InsertMenu (menu, 1, MF_BYPOSITION | MF_SEPARATOR, 0, NULL);
633 SetMenuDefaultItem (menu, 0, MF_BYPOSITION);
634 }
635 }
636
637 static Lisp_Object
638 find_menu (Lisp_Object desc, Lisp_Object path)
639 {
640 /* #### find-menu-item is not what's required here.
641 Need to write this in C, or improve lisp */
642 if (!NILP (path))
643 {
644 desc = call2 (Qfind_menu_item, desc, path);
645 /* desc is (supposed to be) (ITEM . PARENT). Supposed
646 to signal but sometimes manages to return nil */
647 if (!NILP(desc))
648 {
649 CHECK_CONS (desc);
650 desc = XCAR (desc);
651 }
652 }
653 return desc;
654 }
655
656 static void
657 update_frame_menubar_maybe (struct frame* f)
658 {
659 HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f));
660 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
661 Lisp_Object desc = (!NILP (w->menubar_visible_p)
662 ? symbol_value_in_buffer (Qcurrent_menubar, w->buffer)
663 : Qnil);
664
665 if (NILP (desc) && menubar != NULL)
666 {
667 /* Menubar has gone */
668 FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil;
669 DestroyMenu (menubar);
670 DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f));
671 return;
672 }
673
674 if (!NILP (desc) && menubar == NULL)
675 {
676 /* Menubar has appeared */
677 menubar = CreateMenu ();
678 goto populate;
679 }
680
681 if (NILP (desc))
682 {
683 /* We did not have the bar and are not going to */
684 return;
685 }
686
687 /* Now we have to check if the menubar has really changed */
688 /* #### For now we do not though */
689
690 /* We cannot re-create the menu, cause WM_INITMENU does not like that.
691 We'll clear it instead. */
692 empty_menu (menubar, 0);
693
694 populate:
695 /* Come with empty hash table */
696 if (NILP (FRAME_MSWINDOWS_MENU_HASHTABLE(f)))
697 FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Fmake_hashtable (make_int (50), Qequal);
698 else
699 Fclrhash (FRAME_MSWINDOWS_MENU_HASHTABLE(f));
700
701 Fputhash (hmenu_to_lisp_object (menubar), Qnil,
702 FRAME_MSWINDOWS_MENU_HASHTABLE(f));
703 populate_menu (menubar, Qnil, desc,
704 FRAME_MSWINDOWS_MENU_HASHTABLE(f), 1);
705 SetMenu (FRAME_MSWINDOWS_HANDLE (f), menubar);
706 DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f));
707 }
708
709 static void
710 prune_menubar (struct frame *f)
711 {
712 HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f));
713 Lisp_Object desc = current_frame_menubar (f);
714 if (menubar == NULL)
715 return;
716
717 /* #### If a filter function has set desc to Qnil, this abort()
718 triggers. To resolve, we must prevent explicitely filters from
719 mangling with te active menu. In apply_filter probably?
720 Is copy-tree on the whole menu too expensive? */
721 if (NILP(desc))
722 /* abort(); */
723 return;
724
725 /* We do the trick by removing all items and re-populating top level */
726 empty_menu (menubar, 0);
727
728 assert (HASHTABLEP (FRAME_MSWINDOWS_MENU_HASHTABLE(f)));
729 Fclrhash (FRAME_MSWINDOWS_MENU_HASHTABLE(f));
730
731 Fputhash (hmenu_to_lisp_object (menubar), Qnil,
732 FRAME_MSWINDOWS_MENU_HASHTABLE(f));
733 populate_menu (menubar, Qnil, desc,
734 FRAME_MSWINDOWS_MENU_HASHTABLE(f), 1);
735 }
736
737 /*
738 * This is called when cleanup is possible. It is better not to
739 * clean things up at all than do it too earaly!
740 */
741 static void
742 menu_cleanup (struct frame *f)
743 {
744 /* This function can GC */
745 if (!NILP (current_tracking_popup))
746 {
747 current_tracking_popup = Qnil;
748 current_popup_hash_table = Qnil;
749 }
750 else
751 prune_menubar (f);
752 }
753
754
755 /*------------------------------------------------------------------------*/
756 /* Message handlers */
757 /*------------------------------------------------------------------------*/
758 static Lisp_Object
759 unsafe_handle_wm_initmenupopup_1 (HMENU menu, struct frame* f)
760 {
761 /* This function can call lisp, beat dogs and stick chewing gum to
762 everything! */
763
764 Lisp_Object path, desc, hash_tab;
765 struct gcpro gcpro1;
766
767 if (!NILP (current_tracking_popup))
768 {
769 desc = current_tracking_popup;
770 hash_tab = current_popup_hash_table;
771 }
772 else
773 {
774 desc = current_frame_menubar (f);
775 hash_tab = FRAME_MSWINDOWS_MENU_HASHTABLE(f);
776 }
777
778 /* Find which guy is going to explode */
779 path = Fgethash (hmenu_to_lisp_object (menu), hash_tab, Qunbound);
780 assert (!UNBOUNDP (path));
781
782 /* Now find a desc chunk for it. If none, then probably menu open
783 hook has played too much games around stuff */
784 if (!NILP (path))
785 {
786 desc = find_menu (desc, path);
787 if (NILP (desc))
788 signal_simple_error ("this menu does not exist any more", path);
789 }
790
791 /* Now, stuff it */
792 /* DESC may be generated by filter, so we have to gcpro it */
793 GCPRO1 (desc);
794 populate_menu (menu, path, desc, hash_tab, 0);
795 UNGCPRO;
796 return Qt;
797 }
798
799 static Lisp_Object
800 unsafe_handle_wm_initmenu_1 (struct frame* f)
801 {
802 /* This function can call lisp */
803 /* #### - this menubar update mechanism is expensively anti-social and
804 the activate-menubar-hook is now mostly obsolete. */
805
806 /* We simply ignore return value. In any case, we construct the bar
807 on the fly */
808 run_hook (Vactivate_menubar_hook);
809
810 update_frame_menubar_maybe (f);
811 return Qt;
812 }
813
814
815 #ifdef KKM_DOES_NOT_LIKE_UNDOCS_SOMETIMES
816
817 /* #### This may become wrong in future Windows */
818
819 static Lisp_Object
820 unsafe_handle_wm_exitmenuloop_1 (struct frame* f)
821 {
822 if (!NILP (current_tracking_popup))
823 prune_menubar (f);
824 return Qt;
825 }
826
827 #endif
828
829 /*
830 * Return value is Qt if we have dispatched the command,
831 * or Qnil if id has not been mapped to a callback.
832 * Window procedure may try other targets to route the
833 * command if we return nil
834 */
835 Lisp_Object
836 mswindows_handle_wm_command (struct frame* f, WORD id)
837 {
838 /* Try to map the command id through the proper hash table */
839 Lisp_Object hash_tab, command, funcsym, frame;
840 struct gcpro gcpro1;
841
842 if (!NILP (current_tracking_popup))
843 hash_tab = current_popup_hash_table;
844 else
845 hash_tab = FRAME_MSWINDOWS_MENU_HASHTABLE(f);
846
847 command = Fgethash (make_int (id), hash_tab, Qunbound);
848 if (UNBOUNDP (command))
849 {
850 menu_cleanup (f);
851 return Qnil;
852 }
853
854 /* Need to gcpro because the hashtable may get destroyed
855 by menu_cleanup(), and will not gcpro the command
856 any more */
857 GCPRO1 (command);
858 menu_cleanup (f);
859
860 /* Ok, this is our one. Enqueue it. */
861 #if 0
862 if (SYMBOLP (command))
863 Fcall_interactively (command, Qnil, Qnil);
864 else if (CONSP (command))
865 Feval (command);
866 else
867 signal_simple_error ("illegal callback", command);
868 #endif
869 if (SYMBOLP (command))
870 funcsym = Qcall_interactively;
871 else if (CONSP (command))
872 funcsym = Qeval;
873 else
874 signal_simple_error ("illegal callback", command);
875
876 XSETFRAME (frame, f);
877 enqueue_misc_user_event (frame, funcsym, command);
878
879 UNGCPRO; /* command */
880 return Qt;
881 }
882
883
884 /*------------------------------------------------------------------------*/
885 /* Message handling proxies */
886 /*------------------------------------------------------------------------*/
887
888 static HMENU wm_initmenu_menu;
889 static struct frame* wm_initmenu_frame;
890
891 static Lisp_Object
892 unsafe_handle_wm_initmenupopup (Lisp_Object u_n_u_s_e_d)
893 {
894 return unsafe_handle_wm_initmenupopup_1 (wm_initmenu_menu, wm_initmenu_frame);
895 }
896
897 static Lisp_Object
898 unsafe_handle_wm_initmenu (Lisp_Object u_n_u_s_e_d)
899 {
900 return unsafe_handle_wm_initmenu_1 (wm_initmenu_frame);
901 }
902
903 #ifdef KKM_DOES_NOT_LIKE_UNDOCS_SOMETIMES
904 static Lisp_Object
905 unsafe_handle_wm_exitmenuloop (Lisp_Object u_n_u_s_e_d)
906 {
907 return unsafe_handle_wm_exitmenuloop_1 (wm_initmenu_frame);
908 }
909 #endif
910
911 Lisp_Object
912 mswindows_handle_wm_initmenupopup (HMENU hmenu, struct frame* frm)
913 {
914 /* We cannot pass hmenu as a lisp object. Use static var */
915 wm_initmenu_menu = hmenu;
916 wm_initmenu_frame = frm;
917 return mswindows_protect_modal_loop (unsafe_handle_wm_initmenupopup, Qnil);
918 }
919
920 Lisp_Object
921 mswindows_handle_wm_initmenu (struct frame* f)
922 {
923 wm_initmenu_frame = f;
924 return mswindows_protect_modal_loop (unsafe_handle_wm_initmenu, Qnil);
925 }
926
927 Lisp_Object
928 mswindows_handle_wm_exitmenuloop (struct frame* f)
929 {
930 #ifdef KKM_DOES_NOT_LIKE_UNDOCS_SOMETIMES
931 wm_initmenu_frame = f;
932 return mswindows_protect_modal_loop (unsafe_handle_wm_exitmenuloop, Qnil);
933 #else
934 return Qt;
935 #endif
936 }
937
938
939 /*------------------------------------------------------------------------*/
940 /* Methods */
941 /*------------------------------------------------------------------------*/
942
943 static void
944 mswindows_update_frame_menubars (struct frame* f)
945 {
946 update_frame_menubar_maybe (f);
947 }
948
949 static void
950 mswindows_free_frame_menubars (struct frame* f)
951 {
952 FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil;
953 }
954
955 static void
956 mswindows_popup_menu (Lisp_Object menu_desc, Lisp_Object event)
957 {
958 struct frame *f = selected_frame ();
959 struct Lisp_Event *eev = NULL;
960 HMENU menu;
961 POINT pt;
962 int ok;
963
964 if (!NILP (event))
965 {
966 CHECK_LIVE_EVENT (event);
967 eev = XEVENT (event);
968 if (eev->event_type != button_press_event
969 && eev->event_type != button_release_event)
970 wrong_type_argument (Qmouse_event_p, event);
971 }
972 else if (!NILP (Vthis_command_keys))
973 {
974 /* if an event wasn't passed, use the last event of the event sequence
975 currently being executed, if that event is a mouse event */
976 eev = XEVENT (Vthis_command_keys); /* last event first */
977 if (eev->event_type != button_press_event
978 && eev->event_type != button_release_event)
979 eev = NULL;
980 }
981
982 /* Default is to put the menu at the point (10, 10) in frame */
983 if (eev)
984 {
985 pt.x = eev->event.button.x;
986 pt.y = eev->event.button.y;
987 ClientToScreen (FRAME_MSWINDOWS_HANDLE (f), &pt);
988 }
989 else
990 pt.x = pt.y = 10;
991
992 if (SYMBOLP (menu_desc))
993 menu_desc = Fsymbol_value (menu_desc);
994
995 current_tracking_popup = menu_desc;
996 current_popup_hash_table = Fmake_hashtable (make_int(10), Qequal);
997 menu = create_empty_popup_menu();
998 Fputhash (hmenu_to_lisp_object (menu), Qnil, current_popup_hash_table);
999
1000 ok = TrackPopupMenu (menu, TPM_LEFTALIGN | TPM_LEFTBUTTON,
1001 pt.x, pt.y, 0,
1002 FRAME_MSWINDOWS_HANDLE (f), NULL);
1003
1004 DestroyMenu (menu);
1005
1006 /* Signal a signal if caught by Track...() modal loop */
1007 mswindows_unmodalize_signal_maybe ();
1008
1009 /* This is probably the only real reason for failure */
1010 if (!ok) {
1011 menu_cleanup (f);
1012 signal_simple_error ("cannot track popup menu while in menu",
1013 menu_desc);
1014 }
1015 }
1016
1017
1018 /*------------------------------------------------------------------------*/
1019 /* Initialization */
1020 /*------------------------------------------------------------------------*/
1021 void
1022 syms_of_menubar_mswindows (void)
1023 {
1024 defsymbol (&Qfind_menu_item, "find-menu-item");
1025 }
1026
1027 void
1028 console_type_create_menubar_mswindows (void)
1029 {
1030 CONSOLE_HAS_METHOD (mswindows, update_frame_menubars);
1031 CONSOLE_HAS_METHOD (mswindows, free_frame_menubars);
1032 CONSOLE_HAS_METHOD (mswindows, popup_menu);
1033 }
1034
1035 void
1036 vars_of_menubar_mswindows (void)
1037 {
1038 current_tracking_popup = Qnil;
1039 current_popup_hash_table = Qnil;
1040
1041 staticpro (&current_tracking_popup);
1042 staticpro (&current_popup_hash_table);
1043
1044 Fprovide (intern ("mswindows-menubars"));
1045 }