update.
[chise/xemacs-chise.git-] / src / menubar-msw.c
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    Copyright (C) 2000 Ben Wing.
6
7 This file is part of XEmacs.
8
9 XEmacs is free software; you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by the
11 Free Software Foundation; either version 2, or (at your option) any
12 later version.
13
14 XEmacs is distributed in the hope that it will be useful, but WITHOUT
15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with XEmacs; see the file COPYING.  If not, write to
21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 Boston, MA 02111-1307, USA.  */
23
24 /* Synched up with: Not in FSF. */
25
26 /* Author:
27    Initially written by kkm 12/24/97,
28    peeking into and copying stuff from menubar-x.c
29    */
30
31 /* Algorithm for handling menus is as follows. When window's menubar
32  * is created, current-menubar is not traversed in depth. Rather, only
33  * top level items, both items and pulldowns, are added to the
34  * menubar. Each pulldown is initially empty. When a pulldown is
35  * selected and about to open, corresponding element of
36  * current-menubar is found, and the newly open pulldown is
37  * populated. This is made again in the same non-recursive manner.
38  *
39  * This algorithm uses hash tables to find out element of the menu
40  * descriptor list given menu handle. The key is an opaque ptr data
41  * type, keeping menu handle, and the value is a list of strings
42  * representing the path from the root of the menu to the item
43  * descriptor. Each frame has an associated hash table.
44  *
45  * Leaf items are assigned a unique id based on item's hash. When an
46  * item is selected, Windows sends back the id. Unfortunately, only
47  * low 16 bit of the ID are sent, and there's no way to get the 32-bit
48  * value. Yes, Win32 is just a different set of bugs than X! Aside
49  * from this blame, another hashing mechanism is required to map menu
50  * ids to commands (which are actually Lisp_Object's). This mapping is
51  * performed in the same hash table, as the lifetime of both maps is
52  * exactly the same. This is unambigous, as menu handles are
53  * represented by lisp opaques, while command ids are by lisp
54  * integers. The additional advantage for this is that command forms
55  * are automatically GC-protected, which is important because these
56  * may be transient forms generated by :filter functions.
57  *
58  * The hash table is not allowed to grow too much; it is pruned
59  * whenever this is safe to do. This is done by re-creating the menu
60  * bar, and clearing and refilling the hash table from scratch.
61  *
62  * Popup menus are handled identically to pulldowns. A static hash
63  * table is used for popup menus, and lookup is made not in
64  * current-menubar but in a lisp form supplied to the `popup'
65  * function.
66  *
67  * Another Windows weirdness is that there's no way to tell that a
68  * popup has been dismissed without making selection. We need to know
69  * that to cleanup the popup menu hash table, but this is not honestly
70  * doable using *documented* sequence of messages. Sticking to
71  * particular knowledge is bad because this may break in Windows NT
72  * 5.0, or Windows 98, or other future version. Instead, I allow the
73  * hash tables to hang around, and not clear them, unless WM_COMMAND is
74  * received. This is worth some memory but more safe. Hacks welcome,
75  * anyways!
76  *
77  */
78
79 #include <config.h>
80 #include "lisp.h"
81
82 #include "buffer.h"
83 #include "commands.h"
84 #include "console-msw.h"
85 #include "elhash.h"
86 #include "events.h"
87 #include "frame.h"
88 #include "gui.h"
89 #include "lisp.h"
90 #include "menubar.h"
91 #include "menubar-msw.h"
92 #include "opaque.h"
93 #include "window.h"
94
95 /* #### */
96 #define REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIGHT_FLUSH 0
97
98 #define EMPTY_ITEM_ID ((UINT)LISP_TO_VOID (Qunbound))
99 #define EMPTY_ITEM_NAME "(empty)"
100
101 /* Current menu (bar or popup) descriptor. gcpro'ed */
102 static Lisp_Object current_menudesc;
103
104 /* Current menubar or popup hash table. gcpro'ed */
105 static Lisp_Object current_hash_table;
106
107 /* This is used to allocate unique ids to menu items.
108    Items ids are in MENU_ITEM_ID_MIN to MENU_ITEM_ID_MAX.
109    Allocation checks that the item is not already in
110    the TOP_LEVEL_MENU */
111
112 /* #### defines go to gui-msw.h, as the range is shared with toolbars
113    (If only toolbars will be implemented as common controls) */
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 /*
120  * Translate (in place) X accelerator syntax to win32 accelerator syntax.
121  * Return new length.
122  * len = number of bytes (not including zero terminator).
123  * maxlen = size of buffer.
124  * accel = (Emchar*) to receive the accelerator character
125  *         or NULL to suppress accelerators in the menu or dialog item.
126  *
127  * %% is replaced with %
128  * if accel is NULL:
129  *   %_ is removed.
130  * if accel is non-NULL:
131  *   %_ is replaced with &.
132  *   The accelerator character is passed back in *accel.
133  *   (If there is no accelerator, it will be added on the first character.)
134  *
135  * We assume and maintain zero-termination.  To be absolutely sure
136  * of not hitting an error, maxlen should be >= 2*len + 3.
137  */
138 Bytecount
139 mswindows_translate_menu_or_dialog_item (Bufbyte *item, Bytecount len,
140                                          Bytecount maxlen, Emchar *accel,
141                                          Lisp_Object error_name)
142 {
143   Bufbyte *ptr;
144
145   if (accel)
146     *accel = '\0';
147
148   /* Escape '&' as '&&' */
149   ptr = item;
150   while ((ptr = (Bufbyte *) memchr (ptr, '&', len - (ptr - item))) != NULL)
151     {
152       if (len + 2 > maxlen)
153         syntax_error ("Menu item produces too long displayable string",
154                       error_name);
155       memmove (ptr + 1, ptr, (len - (ptr - item)) + 1);
156       len++;
157       ptr += 2;
158     }
159
160   /* Replace XEmacs accelerator '%_' with Windows accelerator '&'
161      and `%%' with `%'. */
162   ptr = item;
163   while ((ptr = memchr (ptr, '%', len - (ptr - item))) != NULL)
164     {
165       if (*(ptr + 1) == '_')
166         {
167           if (accel)
168             {
169               *ptr = '&';
170               if (!*accel)
171                 /* #### urk !  We need a reference translation table for
172                    case changes that aren't buffer-specific. */
173                 *accel = DOWNCASE (current_buffer, charptr_emchar (ptr + 2));
174               memmove (ptr + 1, ptr + 2, len - (ptr - item + 2) + 1);
175               len--;
176             }
177           else  /* Skip accelerator */
178             {
179               memmove (ptr, ptr + 2, len - (ptr - item + 2) + 1);
180               len-=2;
181             }
182         }
183       else if (*(ptr + 1) == '%')
184         {
185           memmove (ptr + 1, ptr + 2, len - (ptr - item + 2) + 1);
186           len--;
187           ptr++;
188         }
189       else      /* % on its own - shouldn't happen */
190         ptr++;
191     }
192
193   if (accel && !*accel)
194     {
195       /* Force a default accelerator */
196       if (len + 2 > maxlen)
197         syntax_error ("Menu item produces too long displayable string",
198                       error_name);
199       ptr = item;
200       memmove (ptr + 1, ptr, len + 1);
201       /* #### urk !  We need a reference translation table for
202          case changes that aren't buffer-specific. */
203       *accel = DOWNCASE (current_buffer, charptr_emchar (ptr + 1));
204       *ptr = '&';
205
206       len++;
207     }
208
209   return len;
210 }
211
212 /*
213  * This returns Windows-style menu item string:
214  * "Left Flush\tRight Flush"
215  */
216
217 /* #### This is junk.  Need correct handling of sizes.  Use a Bufbyte_dynarr,
218    not a static buffer. */
219 static char*
220 displayable_menu_item (Lisp_Object gui_item, int bar_p, Emchar *accel)
221 {
222   unsigned int ll;
223
224   /* We construct the name in a static buffer. That's fine, because
225      menu items longer than 128 chars are probably programming errors,
226      and better be caught than displayed! */
227
228   static char buf[MAX_MENUITEM_LENGTH+2];
229
230   /* Left flush part of the string */
231   ll = gui_item_display_flush_left (gui_item, buf, MAX_MENUITEM_LENGTH);
232
233   ll = mswindows_translate_menu_or_dialog_item ((Bufbyte *) buf, ll,
234                                           MAX_MENUITEM_LENGTH, accel,
235                                           XGUI_ITEM (gui_item)->name);
236
237   /* Right flush part, unless we're at the top-level where it's not allowed */
238   if (!bar_p)
239     {
240       unsigned int lr;
241
242       assert (MAX_MENUITEM_LENGTH > ll + 1);
243       lr = gui_item_display_flush_right (gui_item, buf + ll + 1,
244                                          MAX_MENUITEM_LENGTH - ll - 1);
245       if (lr)
246         buf [ll] = '\t';
247      }
248
249   return buf;
250 }
251
252 /*
253  * hmenu_to_lisp_object() returns an opaque ptr given menu handle.
254  */
255 static Lisp_Object
256 hmenu_to_lisp_object (HMENU hmenu)
257 {
258   return make_opaque_ptr (hmenu);
259 }
260
261 /*
262  * Allocation tries a hash based on item's path and name first. This
263  * almost guarantees that the same item will override its old value in
264  * the hash table rather than abandon it.
265  */
266 static Lisp_Object
267 allocate_menu_item_id (Lisp_Object path, Lisp_Object name, Lisp_Object suffix)
268 {
269   UINT id = MENU_ITEM_ID_BITS (HASH3 (internal_hash (path, 0),
270                                       internal_hash (name, 0),
271                                       internal_hash (suffix, 0)));
272   do {
273       id = MENU_ITEM_ID_BITS (id + 1);
274   } while (GetMenuState (top_level_menu, id, MF_BYCOMMAND) != 0xFFFFFFFF);
275   return make_int (id);
276 }
277
278 static HMENU
279 create_empty_popup_menu (void)
280 {
281   return CreatePopupMenu ();
282 }
283
284 static void
285 empty_menu (HMENU menu, int add_empty_p)
286 {
287   while (DeleteMenu (menu, 0, MF_BYPOSITION));
288   if (add_empty_p)
289     AppendMenu (menu, MF_STRING | MF_GRAYED, EMPTY_ITEM_ID, EMPTY_ITEM_NAME);
290 }
291
292 /*
293  * The idea of checksumming is that we must hash minimal object
294  * which is necessarily changes when the item changes. For separator
295  * this is a constant, for grey strings and submenus these are hashes
296  * of names, since submenus are unpopulated until opened so always
297  * equal otherwise. For items, this is a full hash value of a callback,
298  * because a callback may me a form which can be changed only somewhere
299  * in depth.
300  */
301 static unsigned long
302 checksum_menu_item (Lisp_Object item)
303 {
304   if (STRINGP (item))
305     {
306       /* Separator or unselectable text - hash as a string + 13 */
307       if (separator_string_p (XSTRING_DATA (item)))
308         return 13;
309       else
310         return internal_hash (item, 0) + 13;
311     }
312   else if (CONSP (item))
313     {
314       /* Submenu - hash by its string name + 0 */
315       return internal_hash (XCAR(item), 0);
316     }
317   else if (VECTORP (item))
318     {
319       /* An ordinary item - hash its name and callback form. */
320       return HASH2 (internal_hash (XVECTOR_DATA(item)[0], 0),
321                     internal_hash (XVECTOR_DATA(item)[1], 0));
322     }
323
324   /* An error - will be caught later */
325   return 0;
326 }
327
328 static void
329 populate_menu_add_item (HMENU menu, Lisp_Object path,
330                         Lisp_Object hash_tab, Lisp_Object item,
331                         Lisp_Object *accel_list,
332                         int flush_right, int bar_p)
333 {
334   MENUITEMINFO item_info;
335   UINT oldflags = MF_BYPOSITION;
336   UINT olduidnewitem = 0;
337   LPCTSTR oldlpnewitem = 0;
338
339   item_info.cbSize = sizeof (item_info);
340   item_info.fMask = MIIM_TYPE | MIIM_STATE | MIIM_ID;
341   item_info.fState = 0;
342   item_info.wID = 0;
343   item_info.fType = 0;
344
345   if (STRINGP (item))
346     {
347       /* Separator or unselectable text */
348       if (separator_string_p (XSTRING_DATA (item)))
349         {
350           item_info.fType = MFT_SEPARATOR;
351           oldflags |= MF_SEPARATOR;
352         }
353       else
354         {
355           item_info.fType = MFT_STRING;
356           item_info.fState = MFS_DISABLED;
357           item_info.dwTypeData = XSTRING_DATA (item);
358           oldflags |= MF_STRING | MF_DISABLED;
359           oldlpnewitem = item_info.dwTypeData;
360         }
361     }
362   else if (CONSP (item))
363     {
364       /* Submenu */
365       HMENU submenu;
366       Lisp_Object gui_item = allocate_gui_item ();
367       Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
368       struct gcpro gcpro1, gcpro2, gcpro3;
369       Emchar accel;
370
371       GCPRO3 (gui_item, path, *accel_list);
372
373       menu_parse_submenu_keywords (item, gui_item);
374
375       if (!STRINGP (pgui_item->name))
376         syntax_error ("Menu name (first element) must be a string",
377                              item);
378
379       if (!gui_item_included_p (gui_item, Vmenubar_configuration))
380         {
381           UNGCPRO;
382           goto done;
383         }
384
385       if (!gui_item_active_p (gui_item))
386         {
387           item_info.fState = MFS_GRAYED;
388           oldflags |= MF_GRAYED;
389         }
390       /* Temptation is to put 'else' right here. Although, the
391          displayed item won't have an arrow indicating that it is a
392          popup.  So we go ahead a little bit more and create a popup */
393       submenu = create_empty_popup_menu ();
394
395       item_info.fMask |= MIIM_SUBMENU;
396       item_info.dwTypeData = displayable_menu_item (gui_item, bar_p, &accel);
397       item_info.hSubMenu = submenu;
398       olduidnewitem = (UINT) submenu;
399       oldlpnewitem = item_info.dwTypeData;
400       oldflags |= MF_POPUP;
401
402       if (accel && bar_p)
403         *accel_list = Fcons (make_char (accel), *accel_list);
404
405       if (!(item_info.fState & MFS_GRAYED))
406         {
407           /* Now add the full submenu path as a value to the hash table,
408              keyed by menu handle */
409           if (NILP(path))
410             path = list1 (pgui_item->name);
411           else
412             {
413               Lisp_Object arg[2];
414               arg[0] = path;
415               arg[1] = list1 (pgui_item->name);
416               path = Fappend (2, arg);
417             }
418
419           Fputhash (hmenu_to_lisp_object (submenu), path, hash_tab);
420         }
421       UNGCPRO;
422     }
423   else if (VECTORP (item))
424     {
425       /* An ordinary item */
426       Lisp_Object style, id;
427       Lisp_Object gui_item = gui_parse_item_keywords (item);
428       Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
429       struct gcpro gcpro1, gcpro2;
430       Emchar accel;
431
432       GCPRO2 (gui_item, *accel_list);
433
434       if (!gui_item_included_p (gui_item, Vmenubar_configuration))
435         {
436           UNGCPRO;
437           goto done;
438         }
439
440       if (!STRINGP (pgui_item->name))
441         pgui_item->name = Feval (pgui_item->name);
442
443       if (!gui_item_active_p (gui_item))
444         {
445           item_info.fState = MFS_GRAYED;
446           oldflags = MF_GRAYED;
447         }
448
449       style = (NILP (pgui_item->selected) || NILP (Feval (pgui_item->selected))
450                ? Qnil : pgui_item->style);
451
452       if (EQ (style, Qradio))
453         {
454           item_info.fType |= MFT_RADIOCHECK;
455           item_info.fState |= MFS_CHECKED;
456           oldflags |= MF_CHECKED; /* Can't support radio-button checkmarks
457                                      under 3.51 */
458         }
459       else if (EQ (style, Qtoggle))
460         {
461           item_info.fState |= MFS_CHECKED;
462           oldflags |= MF_CHECKED;
463         }
464
465       id = allocate_menu_item_id (path, pgui_item->name,
466                                   pgui_item->suffix);
467       Fputhash (id, pgui_item->callback, hash_tab);
468
469       item_info.wID = (UINT) XINT (id);
470       item_info.fType |= MFT_STRING;
471       item_info.dwTypeData = displayable_menu_item (gui_item, bar_p, &accel);
472       olduidnewitem = item_info.wID;
473       oldflags |= MF_STRING;
474       oldlpnewitem = item_info.dwTypeData;
475
476       if (accel && bar_p)
477         *accel_list = Fcons (make_char (accel), *accel_list);
478
479       UNGCPRO;
480     }
481   else
482     syntax_error ("Malformed menu item descriptor", item);
483
484   if (flush_right)
485     item_info.fType |= MFT_RIGHTJUSTIFY; /* can't support in 3.51 */
486
487   if (xInsertMenuItemA)
488     xInsertMenuItemA (menu, UINT_MAX, TRUE, &item_info);
489   else
490     InsertMenu (menu, UINT_MAX, oldflags, olduidnewitem, oldlpnewitem);
491
492 done:;
493 }
494
495 /*
496  * This function is called from populate_menu and checksum_menu.
497  * When called to populate, MENU is a menu handle, PATH is a
498  * list of strings representing menu path from root to this submenu,
499  * DESCRIPTOR is a menu descriptor, HASH_TAB is a hash table associated
500  * with root menu, BAR_P indicates whether this called for a menubar or
501  * a popup, and POPULATE_P is non-zero. Return value must be ignored.
502  * When called to checksum, DESCRIPTOR has the same meaning, POPULATE_P
503  * is zero, PATH must be Qnil, and the rest of parameters is ignored.
504  * Return value is the menu checksum.
505  */
506 static unsigned long
507 populate_or_checksum_helper (HMENU menu, Lisp_Object path, Lisp_Object desc,
508                              Lisp_Object hash_tab, int bar_p, int populate_p)
509 {
510   Lisp_Object item_desc;
511   int deep_p, flush_right;
512   struct gcpro gcpro1, gcpro2, gcpro3;
513   unsigned long checksum;
514   Lisp_Object gui_item = allocate_gui_item ();
515   Lisp_Object accel_list = Qnil;
516   Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
517
518   GCPRO3 (gui_item, accel_list, desc);
519
520   /* We are sometimes called with the menubar unchanged, and with changed
521      right flush. We have to update the menubar in this case,
522      so account for the compliance setting in the hash value */
523   checksum = REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIGHT_FLUSH;
524
525   /* Will initially contain only "(empty)" */
526   if (populate_p)
527     empty_menu (menu, 1);
528
529   /* PATH set to nil indicates top-level popup or menubar */
530   deep_p = !NILP (path);
531
532   /* Fetch keywords prepending the item list */
533   desc = menu_parse_submenu_keywords (desc, gui_item);
534
535   /* Check that menu name is specified when expected */
536   if (NILP (pgui_item->name) && deep_p)
537     syntax_error ("Menu must have a name", desc);
538
539   /* Apply filter if specified */
540   if (!NILP (pgui_item->filter))
541     desc = call1 (pgui_item->filter, desc);
542
543   /* Loop thru the desc's CDR and add items for each entry */
544   flush_right = 0;
545   EXTERNAL_LIST_LOOP (item_desc, desc)
546     {
547       if (NILP (XCAR (item_desc)))
548         {
549           /* Do not flush right menubar items when MS style compliant */
550           if (bar_p && !REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIGHT_FLUSH)
551             flush_right = 1;
552           if (!populate_p)
553             checksum = HASH2 (checksum, LISP_HASH (Qnil));
554         }
555       else if (populate_p)
556         populate_menu_add_item (menu, path, hash_tab,
557                                 XCAR (item_desc), &accel_list,
558                                 flush_right, bar_p);
559       else
560         checksum = HASH2 (checksum,
561                           checksum_menu_item (XCAR (item_desc)));
562     }
563
564   if (populate_p)
565     {
566       /* Remove the "(empty)" item, if there are other ones */
567       if (GetMenuItemCount (menu) > 1)
568         RemoveMenu (menu, EMPTY_ITEM_ID, MF_BYCOMMAND);
569
570       /* Add the header to the popup, if told so. The same as in X - an
571          insensitive item, and a separator (Seems to me, there were
572          two separators in X... In Windows this looks ugly, anyways.) */
573       if (!bar_p && !deep_p && popup_menu_titles && !NILP (pgui_item->name))
574         {
575           CHECK_STRING (pgui_item->name);
576           InsertMenu (menu, 0, MF_BYPOSITION | MF_STRING | MF_DISABLED,
577                       0, displayable_menu_item (gui_item, bar_p, NULL));
578           InsertMenu (menu, 1, MF_BYPOSITION | MF_SEPARATOR, 0, NULL);
579           if (xSetMenuDefaultItem) /* not in NT 3.5x */
580             xSetMenuDefaultItem (menu, 0, MF_BYPOSITION);
581         }
582     }
583
584   if (bar_p)
585     Fputhash (Qt, accel_list, hash_tab);
586
587   UNGCPRO;
588   return checksum;
589 }
590
591 static void
592 populate_menu (HMENU menu, Lisp_Object path, Lisp_Object desc,
593                Lisp_Object hash_tab, int bar_p)
594 {
595   populate_or_checksum_helper (menu, path, desc, hash_tab, bar_p, 1);
596 }
597
598 static unsigned long
599 checksum_menu (Lisp_Object desc)
600 {
601   return populate_or_checksum_helper (NULL, Qnil, desc, Qunbound, 0, 0);
602 }
603
604 static void
605 update_frame_menubar_maybe (struct frame *f)
606 {
607   HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f));
608   struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
609   Lisp_Object desc = (!NILP (w->menubar_visible_p)
610                       ? symbol_value_in_buffer (Qcurrent_menubar, w->buffer)
611                       : Qnil);
612   struct gcpro gcpro1;
613
614   GCPRO1 (desc); /* it's safest to do this, just in case some filter
615                     or something changes the value of current-menubar */
616
617   top_level_menu = menubar;
618
619   if (NILP (desc) && menubar != NULL)
620     {
621       /* Menubar has gone */
622       FRAME_MSWINDOWS_MENU_HASH_TABLE (f) = Qnil;
623       SetMenu (FRAME_MSWINDOWS_HANDLE (f), NULL);
624       DestroyMenu (menubar);
625       DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f));
626       UNGCPRO;
627       return;
628     }
629
630   if (!NILP (desc) && menubar == NULL)
631     {
632       /* Menubar has appeared */
633       menubar = CreateMenu ();
634       goto populate;
635     }
636
637   if (NILP (desc))
638     {
639       /* We did not have the bar and are not going to */
640       UNGCPRO;
641       return;
642     }
643
644   /* Now we bail out if the menubar has not changed */
645   if (FRAME_MSWINDOWS_MENU_CHECKSUM (f) == checksum_menu (desc))
646     {
647       UNGCPRO;
648       return;
649     }
650
651 populate:
652   /* Come with empty hash table */
653   if (NILP (FRAME_MSWINDOWS_MENU_HASH_TABLE (f)))
654     FRAME_MSWINDOWS_MENU_HASH_TABLE (f) =
655       make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
656   else
657     Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE (f));
658
659   Fputhash (hmenu_to_lisp_object (menubar), Qnil,
660             FRAME_MSWINDOWS_MENU_HASH_TABLE (f));
661   populate_menu (menubar, Qnil, desc,
662                  FRAME_MSWINDOWS_MENU_HASH_TABLE (f), 1);
663   SetMenu (FRAME_MSWINDOWS_HANDLE (f), menubar);
664   DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f));
665
666   FRAME_MSWINDOWS_MENU_CHECKSUM (f) = checksum_menu (desc);
667
668   UNGCPRO;
669 }
670
671 static void
672 prune_menubar (struct frame *f)
673 {
674   HMENU menubar = GetMenu (FRAME_MSWINDOWS_HANDLE (f));
675   Lisp_Object desc = current_frame_menubar (f);
676   struct gcpro gcpro1;
677
678   if (menubar == NULL)
679     return;
680
681   /* #### If a filter function has set desc to Qnil, this abort()
682      triggers. To resolve, we must prevent filters explicitly from
683      mangling with the active menu. In apply_filter probably?
684      Is copy-tree on the whole menu too expensive? */
685   if (NILP (desc))
686     /* abort(); */
687     return;
688
689   GCPRO1 (desc); /* just to be safe -- see above */
690   /* We do the trick by removing all items and re-populating top level */
691   empty_menu (menubar, 0);
692
693   assert (HASH_TABLEP (FRAME_MSWINDOWS_MENU_HASH_TABLE (f)));
694   Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE (f));
695
696   Fputhash (hmenu_to_lisp_object (menubar), Qnil,
697             FRAME_MSWINDOWS_MENU_HASH_TABLE (f));
698   populate_menu (menubar, Qnil, desc,
699                  FRAME_MSWINDOWS_MENU_HASH_TABLE (f), 1);
700   UNGCPRO;
701 }
702
703 /*
704  * This is called when cleanup is possible. It is better not to
705  * clean things up at all than do it too early!
706  */
707 static void
708 menu_cleanup (struct frame *f)
709 {
710   /* This function can GC */
711   current_menudesc = Qnil;
712   current_hash_table = Qnil;
713   prune_menubar (f);
714 }
715
716 int
717 mswindows_char_is_accelerator (struct frame *f, Emchar ch)
718 {
719   Lisp_Object hash = FRAME_MSWINDOWS_MENU_HASH_TABLE (f);
720
721   if (NILP (hash))
722     return 0;
723   /* !!#### not Mule-ized */
724   return !NILP (memq_no_quit (make_char (tolower (ch)),
725                               Fgethash (Qt, hash, Qnil)));
726 }
727
728 \f
729 /*------------------------------------------------------------------------*/
730 /* Message handlers                                                       */
731 /*------------------------------------------------------------------------*/
732 static Lisp_Object
733 unsafe_handle_wm_initmenupopup_1 (HMENU menu, struct frame *f)
734 {
735   /* This function can call lisp, beat dogs and stick chewing gum to
736      everything! */
737
738   Lisp_Object path, desc;
739   struct gcpro gcpro1;
740   
741   /* Find which guy is going to explode */
742   path = Fgethash (hmenu_to_lisp_object (menu), current_hash_table, Qunbound);
743   assert (!UNBOUNDP (path));
744 #ifdef DEBUG_XEMACS
745   /* Allow to continue in a debugger after assert - not so fatal */
746   if (UNBOUNDP (path))
747     error ("internal menu error");
748 #endif
749
750   /* Now find a desc chunk for it. If none, then probably menu open
751      hook has played too much games around stuff */
752   desc = Fmenu_find_real_submenu (current_menudesc, path);
753   if (NILP (desc))
754     signal_simple_error ("This menu does not exist any more", path);
755
756   /* Now, stuff it */
757   /* DESC may be generated by filter, so we have to gcpro it */
758   GCPRO1 (desc);
759   populate_menu (menu, path, desc, current_hash_table, 0);
760   UNGCPRO;
761   return Qt;
762 }
763
764 static Lisp_Object
765 unsafe_handle_wm_initmenu_1 (struct frame *f)
766 {
767   /* This function can call lisp */
768
769   /* NOTE: This is called for the bar only, WM_INITMENU
770      for popups is filtered out */
771
772   /* #### - this menubar update mechanism is expensively anti-social and
773      the activate-menubar-hook is now mostly obsolete. */
774
775   /* We simply ignore return value. In any case, we construct the bar
776      on the fly */
777   run_hook (Qactivate_menubar_hook);
778
779   update_frame_menubar_maybe (f);
780
781   current_menudesc = current_frame_menubar (f);
782   current_hash_table = FRAME_MSWINDOWS_MENU_HASH_TABLE (f);
783   assert (HASH_TABLEP (current_hash_table));
784
785   return Qt;
786 }
787
788 /*
789  * Return value is Qt if we have dispatched the command,
790  * or Qnil if id has not been mapped to a callback.
791  * Window procedure may try other targets to route the
792  * command if we return nil
793  */
794 Lisp_Object
795 mswindows_handle_wm_command (struct frame *f, WORD id)
796 {
797   /* Try to map the command id through the proper hash table */
798   Lisp_Object data, fn, arg, frame;
799   struct gcpro gcpro1;
800
801   if (NILP (current_hash_table))
802     return Qnil;
803
804   data = Fgethash (make_int (id), current_hash_table, Qunbound);
805
806   if (UNBOUNDP (data))
807     {
808       menu_cleanup (f);
809       return Qnil;
810     }
811
812   /* Need to gcpro because the hash table may get destroyed by
813      menu_cleanup(), and will not gcpro the data any more */
814   GCPRO1 (data);
815   menu_cleanup (f);
816
817   /* Ok, this is our one. Enqueue it. */
818   get_gui_callback (data, &fn, &arg);
819   XSETFRAME (frame, f);
820   /* this used to call mswindows_enqueue_misc_user_event but that
821      breaks customize because the misc_event gets eval'ed in some
822      circumstances. Don't change it back unless you can fix the
823      customize problem also.*/
824   mswindows_enqueue_misc_user_event (frame, fn, arg);
825
826   UNGCPRO; /* data */
827   return Qt;
828 }
829
830 \f
831 /*------------------------------------------------------------------------*/
832 /* Message handling proxies                                               */
833 /*------------------------------------------------------------------------*/
834
835 static HMENU wm_initmenu_menu;
836 static struct frame *wm_initmenu_frame;
837
838 static Lisp_Object
839 unsafe_handle_wm_initmenupopup (Lisp_Object u_n_u_s_e_d)
840 {
841   return unsafe_handle_wm_initmenupopup_1 (wm_initmenu_menu, wm_initmenu_frame);
842 }
843
844 static Lisp_Object
845 unsafe_handle_wm_initmenu (Lisp_Object u_n_u_s_e_d)
846 {
847   return unsafe_handle_wm_initmenu_1 (wm_initmenu_frame);
848 }
849
850 Lisp_Object
851 mswindows_handle_wm_initmenupopup (HMENU hmenu, struct frame *frm)
852 {
853   /* We cannot pass hmenu as a lisp object. Use static var */
854   wm_initmenu_menu = hmenu;
855   wm_initmenu_frame = frm;
856   return mswindows_protect_modal_loop (unsafe_handle_wm_initmenupopup, Qnil);
857 }
858
859 Lisp_Object
860 mswindows_handle_wm_initmenu (HMENU hmenu, struct frame *f)
861 {
862   /* Handle only frame menubar, ignore if from popup or system menu */
863   if (GetMenu (FRAME_MSWINDOWS_HANDLE (f)) == hmenu)
864     {
865       wm_initmenu_frame = f;
866       return mswindows_protect_modal_loop (unsafe_handle_wm_initmenu, Qnil);
867     }
868   return Qt;
869 }
870
871 \f
872 /*------------------------------------------------------------------------*/
873 /* Methods                                                                */
874 /*------------------------------------------------------------------------*/
875
876 static void
877 mswindows_update_frame_menubars (struct frame *f)
878 {
879   update_frame_menubar_maybe (f);
880 }
881
882 static void
883 mswindows_free_frame_menubars (struct frame *f)
884 {
885   FRAME_MSWINDOWS_MENU_HASH_TABLE (f) = Qnil;
886 }
887
888 static void
889 mswindows_popup_menu (Lisp_Object menu_desc, Lisp_Object event)
890 {
891   struct frame *f = selected_frame ();
892   Lisp_Event *eev = NULL;
893   HMENU menu;
894   POINT pt;
895   int ok;
896   struct gcpro gcpro1;
897
898   GCPRO1 (menu_desc); /* to be safe -- see above */
899
900   if (!NILP (event))
901     {
902       CHECK_LIVE_EVENT (event);
903       eev = XEVENT (event);
904       if (eev->event_type != button_press_event
905           && eev->event_type != button_release_event)
906         wrong_type_argument (Qmouse_event_p, event);
907     }
908   else if (!NILP (Vthis_command_keys))
909     {
910       /* if an event wasn't passed, use the last event of the event sequence
911          currently being executed, if that event is a mouse event */
912       eev = XEVENT (Vthis_command_keys); /* last event first */
913       if (eev->event_type != button_press_event
914           && eev->event_type != button_release_event)
915         eev = NULL;
916     }
917
918   popup_up_p++;
919
920   /* Default is to put the menu at the point (10, 10) in frame */
921   if (eev)
922     {
923       pt.x = eev->event.button.x;
924       pt.y = eev->event.button.y;
925       ClientToScreen (FRAME_MSWINDOWS_HANDLE (f), &pt);
926     }
927   else
928     pt.x = pt.y = 10;
929
930   if (SYMBOLP (menu_desc))
931     menu_desc = Fsymbol_value (menu_desc);
932   CHECK_CONS (menu_desc);
933   CHECK_STRING (XCAR (menu_desc));
934
935   menu_cleanup (f);
936
937   current_menudesc = menu_desc;
938   current_hash_table =
939     make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
940   menu = create_empty_popup_menu ();
941   Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hash_table);
942   top_level_menu = menu;
943
944   /* see comments in menubar-x.c */
945   if (zmacs_regions)
946     zmacs_region_stays = 1;
947
948   ok = TrackPopupMenu (menu,
949                        TPM_LEFTALIGN | TPM_LEFTBUTTON | TPM_RIGHTBUTTON,
950                        pt.x, pt.y, 0,
951                        FRAME_MSWINDOWS_HANDLE (f), NULL);
952
953   DestroyMenu (menu);
954
955   /* A WM_COMMAND is not issued until TrackPopupMenu returns. This
956      makes setting popup_up_p fairly pointless since we cannot keep
957      the menu up and dispatch events. Furthermore, we seem to have
958      little control over what happens to the menu when we click. */
959   popup_up_p--;
960
961   /* Signal a signal if caught by Track...() modal loop. */
962   /* I think this is pointless, the code hasn't actually put us in a
963      modal loop at this time -- andyp. */
964   mswindows_unmodalize_signal_maybe ();
965
966   /* This is probably the only real reason for failure */
967   if (!ok)
968     {
969       menu_cleanup (f);
970       signal_simple_error ("Cannot track popup menu while in menu",
971                            menu_desc);
972     }
973   UNGCPRO;
974 }
975
976 \f
977 /*------------------------------------------------------------------------*/
978 /* Initialization                                                         */
979 /*------------------------------------------------------------------------*/
980 void
981 syms_of_menubar_mswindows (void)
982 {
983 }
984
985 void
986 console_type_create_menubar_mswindows (void)
987 {
988   CONSOLE_HAS_METHOD (mswindows, update_frame_menubars);
989   CONSOLE_HAS_METHOD (mswindows, free_frame_menubars);
990   CONSOLE_HAS_METHOD (mswindows, popup_menu);
991 }
992
993 void
994 vars_of_menubar_mswindows (void)
995 {
996   current_menudesc = Qnil;
997   current_hash_table = Qnil;
998
999   staticpro (&current_menudesc);
1000   staticpro (&current_hash_table);
1001 }