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 }