1 /* Implements an elisp-programmable menubar -- X interface.
2 Copyright (C) 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Not in FSF. */
24 /* created 16-dec-91 by jwz */
29 #include "console-x.h"
30 #include "EmacsManager.h"
31 #include "EmacsFrame.h"
32 #include "EmacsShell.h"
36 #include "commands.h" /* zmacs_regions */
43 static int set_frame_menubar (struct frame *f,
47 #define FRAME_MENUBAR_DATA(frame) ((frame)->menubar_data)
48 #define XFRAME_MENUBAR_DATA(frame) XPOPUP_DATA ((frame)->menubar_data)
50 #define MENUBAR_TYPE 0
51 #define SUBMENU_TYPE 1
55 /* Converting Lisp menu tree descriptions to lwlib's `widget_value' form.
57 menu_item_descriptor_to_widget_value() converts a lisp description of a
58 menubar into a tree of widget_value structures. It allocates widget_values
59 with malloc_widget_value() and allocates other storage only for the `key'
60 slot. All other slots are filled with pointers to Lisp_String data. We
61 allocate a widget_value description of the menu or menubar, and hand it to
62 lwlib, which then makes a copy of it, which it manages internally. We then
63 immediately free our widget_value tree; it will not be referenced again.
65 Incremental menu construction callbacks operate just a bit differently.
66 They allocate widget_values and call replace_widget_value_tree() to tell
67 lwlib to destructively modify the incremental stub (subtree) of its
68 separate widget_value tree.
70 This function is highly recursive (it follows the menu trees) and may call
71 eval. The reason we keep pointers to lisp string data instead of copying
72 it and freeing it later is to avoid the speed penalty that would entail
73 (since this needs to be fast, in the simple cases at least). (The reason
74 we malloc/free the keys slot is because there's not a lisp string around
75 for us to use in that case.)
77 Since we keep pointers to lisp strings, and we call eval, we could lose if
78 GC relocates (or frees) those strings. It's not easy to gc protect the
79 strings because of the recursive nature of this function, and the fact that
80 it returns a data structure that gets freed later. So... we do the
81 sleaziest thing possible and inhibit GC for the duration. This is probably
84 We do not have to worry about the pointers to Lisp_String data after
85 this function successfully finishes. lwlib copies all such data with
89 menu_item_descriptor_to_widget_value_1 (Lisp_Object desc,
90 int menu_type, int deep_p,
94 /* This function cannot GC.
95 It is only called from menu_item_descriptor_to_widget_value, which
97 /* !!#### This function has not been Mule-ized */
98 int menubar_root_p = (menu_type == MENUBAR_TYPE && depth == 0);
100 Lisp_Object wv_closure;
101 int count = specpdl_depth ();
102 int partition_seen = 0;
104 wv = xmalloc_widget_value ();
106 wv_closure = make_opaque_ptr (wv);
107 record_unwind_protect (widget_value_unwind, wv_closure);
111 char *string_chars = (char *) XSTRING_DATA (desc);
112 wv->type = (separator_string_p (string_chars) ? SEPARATOR_TYPE :
115 /* #### - should internationalize with X resources instead.
117 string_chars = GETTEXT (string_chars);
119 if (wv->type == SEPARATOR_TYPE)
121 wv->value = menu_separator_style (string_chars);
125 wv->name = string_chars;
129 else if (VECTORP (desc))
131 if (!button_item_to_widget_value (desc, wv, 1,
132 (menu_type == MENUBAR_TYPE
135 /* :included form was nil */
140 else if (CONSP (desc))
142 Lisp_Object incremental_data = desc;
143 widget_value *prev = 0;
145 if (STRINGP (XCAR (desc)))
147 Lisp_Object key, val;
148 Lisp_Object include_p = Qnil, hook_fn = Qnil, config_tag = Qnil;
149 Lisp_Object active_p = Qt;
151 int included_spec = 0;
153 wv->type = CASCADE_TYPE;
155 wv->name = (char *) XSTRING_DATA (LISP_GETTEXT (XCAR (desc)));
157 accel = menu_name_to_accelerator (wv->name);
158 wv->accel = LISP_TO_VOID (accel);
162 while (key = Fcar (desc), KEYWORDP (key))
164 Lisp_Object cascade = desc;
167 signal_simple_error ("keyword in menu lacks a value",
171 if (EQ (key, Q_included))
172 include_p = val, included_spec = 1;
173 else if (EQ (key, Q_config))
175 else if (EQ (key, Q_filter))
177 else if (EQ (key, Q_active))
178 active_p = val, active_spec = 1;
179 else if (EQ (key, Q_accelerator))
183 wv->accel = LISP_TO_VOID (val);
185 signal_simple_error ("bad keyboard accelerator", val);
187 else if (EQ (key, Q_label))
189 /* implement in 21.2 */
192 signal_simple_error ("unknown menu cascade keyword", cascade);
195 if ((!NILP (config_tag)
196 && NILP (Fmemq (config_tag, Vmenubar_configuration)))
197 || (included_spec && NILP (Feval (include_p))))
204 active_p = Feval (active_p);
206 if (!NILP (hook_fn) && !NILP (active_p))
208 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
209 if (filter_p || depth == 0)
212 desc = call1_trapping_errors ("Error in menubar filter",
216 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
220 widget_value *incr_wv = xmalloc_widget_value ();
221 wv->contents = incr_wv;
222 incr_wv->type = INCREMENTAL_TYPE;
223 incr_wv->enabled = 1;
224 incr_wv->name = wv->name;
225 /* This is automatically GC protected through
226 the call to lw_map_widget_values(); no need
228 incr_wv->call_data = LISP_TO_VOID (incremental_data);
231 #endif /* LWLIB_MENUBARS_LUCID || LWLIB_MENUBARS_MOTIF */
233 if (menu_type == POPUP_TYPE && popup_menu_titles && depth == 0)
235 /* Simply prepend three more widget values to the contents of
236 the menu: a label, and two separators (to get a double
238 widget_value *title_wv = xmalloc_widget_value ();
239 widget_value *sep_wv = xmalloc_widget_value ();
240 title_wv->type = TEXT_TYPE;
241 title_wv->name = wv->name;
242 title_wv->enabled = 1;
243 title_wv->next = sep_wv;
244 sep_wv->type = SEPARATOR_TYPE;
245 sep_wv->value = menu_separator_style ("==");
248 wv->contents = title_wv;
251 wv->enabled = ! NILP (active_p);
252 if (deep_p && !wv->enabled && !NILP (desc))
255 /* Add a fake entry so the menus show up */
256 wv->contents = dummy = xmalloc_widget_value ();
257 dummy->name = "(inactive)";
262 dummy->type = BUTTON_TYPE;
263 dummy->call_data = NULL;
270 else if (menubar_root_p)
272 wv->name = (char *) "menubar";
273 wv->type = CASCADE_TYPE; /* Well, nothing else seems to fit and
274 this is ignored anyway... */
278 signal_simple_error ("menu name (first element) must be a string",
282 if (deep_p || menubar_root_p)
285 for (; !NILP (desc); desc = Fcdr (desc))
287 Lisp_Object child = Fcar (desc);
288 if (menubar_root_p && NILP (child)) /* the partition */
292 "more than one partition (nil) in menubar description");
294 next = xmalloc_widget_value ();
295 next->type = PUSHRIGHT_TYPE;
299 next = menu_item_descriptor_to_widget_value_1
300 (child, menu_type, deep_p, filter_p, depth + 1);
311 if (deep_p && !wv->contents)
314 else if (NILP (desc))
315 error ("nil may not appear in menu descriptions");
317 signal_simple_error ("unrecognized menu descriptor", desc);
323 /* Completed normally. Clear out the object that widget_value_unwind()
324 will be called with to tell it not to free the wv (as we are
326 set_opaque_ptr (wv_closure, 0);
329 unbind_to (count, Qnil);
333 static widget_value *
334 menu_item_descriptor_to_widget_value (Lisp_Object desc,
335 int menu_type, /* if this is a menubar,
338 int filter_p) /* if :filter forms
342 int count = specpdl_depth ();
343 record_unwind_protect (restore_gc_inhibit,
344 make_int (gc_currently_forbidden));
345 gc_currently_forbidden = 1;
347 wv = menu_item_descriptor_to_widget_value_1 (desc, menu_type, deep_p,
349 unbind_to (count, Qnil);
354 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
355 int in_menu_callback;
358 restore_in_menu_callback (Lisp_Object val)
360 in_menu_callback = XINT(val);
363 #endif /* LWLIB_MENUBARS_LUCID || LWLIB_MENUBARS_MOTIF */
366 /* #### Sort of a hack needed to process Vactivate_menubar_hook
367 correctly wrt buffer-local values. A correct solution would
368 involve adding a callback mechanism to run_hook(). This function
369 is currently unused. */
371 my_run_hook (Lisp_Object hooksym, int allow_global_p)
373 /* This function can GC */
375 Lisp_Object value = Fsymbol_value (hooksym);
378 if (!NILP (value) && (!CONSP (value) || EQ (XCAR (value), Qlambda)))
379 return !EQ (call0 (value), Qt);
381 EXTERNAL_LIST_LOOP (tail, value)
383 if (allow_global_p && EQ (XCAR (tail), Qt))
384 changes |= my_run_hook (Fdefault_value (hooksym), 0);
385 if (!EQ (call0 (XCAR (tail)), Qt))
393 /* The order in which callbacks are run is funny to say the least.
394 It's sometimes tricky to avoid running a callback twice, and to
395 avoid returning prematurely. So, this function returns true
396 if the menu's callbacks are no longer gc protected. So long
397 as we unprotect them before allowing other callbacks to run,
398 everything should be ok.
400 The pre_activate_callback() *IS* intentionally called multiple times.
401 If client_data == NULL, then it's being called before the menu is posted.
402 If client_data != NULL, then client_data is a (widget_value *) and
403 client_data->data is a Lisp_Object pointing to a lisp submenu description
404 that must be converted into widget_values. *client_data is destructively
407 #### Stig thinks that there may be a GC problem here due to the
408 fact that pre_activate_callback() is called multiple times, but I
414 pre_activate_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
416 /* This function can GC */
417 struct device *d = get_device_from_display (XtDisplay (widget));
418 struct frame *f = x_any_window_to_frame (d, XtWindow (widget));
422 /* set in lwlib to the time stamp associated with the most recent menu
424 extern Time x_focus_timestamp_really_sucks_fix_me_better;
427 f = x_any_window_to_frame (d, XtWindow (XtParent (widget)));
431 /* make sure f is the selected frame */
432 XSETFRAME (frame, f);
433 Fselect_frame (frame);
437 /* this is an incremental menu construction callback */
438 widget_value *hack_wv = (widget_value *) client_data;
439 Lisp_Object submenu_desc;
442 assert (hack_wv->type == INCREMENTAL_TYPE);
443 VOID_TO_LISP (submenu_desc, hack_wv->call_data);
446 * #### Fix the menu code so this isn't necessary.
448 * Protect against reentering the menu code otherwise we will
449 * crash later when the code gets confused at the state
452 count = specpdl_depth ();
453 record_unwind_protect (restore_in_menu_callback,
454 make_int (in_menu_callback));
455 in_menu_callback = 1;
456 wv = menu_item_descriptor_to_widget_value (submenu_desc, SUBMENU_TYPE,
458 unbind_to (count, Qnil);
462 wv = xmalloc_widget_value ();
463 wv->type = CASCADE_TYPE;
465 wv->contents = xmalloc_widget_value ();
466 wv->contents->type = TEXT_TYPE;
467 wv->contents->name = (char *) "No menu";
468 wv->contents->next = NULL;
470 assert (wv && wv->type == CASCADE_TYPE && wv->contents);
471 replace_widget_value_tree (hack_wv, wv->contents);
472 free_popup_widget_value_tree (wv);
474 else if (!POPUP_DATAP (FRAME_MENUBAR_DATA (f)))
478 #if 0 /* Unused, see comment below. */
481 /* #### - this menubar update mechanism is expensively anti-social and
482 the activate-menubar-hook is now mostly obsolete. */
483 any_changes = my_run_hook (Qactivate_menubar_hook, 1);
485 /* #### - It is necessary to *ALWAYS* call set_frame_menubar() now that
486 incremental menus are implemented. If a subtree of a menu has been
487 updated incrementally (a destructive operation), then that subtree
488 must somehow be wiped.
490 It is difficult to undo the destructive operation in lwlib because
491 a pointer back to lisp data needs to be hidden away somewhere. So
492 that an INCREMENTAL_TYPE widget_value can be recreated... Hmmmmm. */
494 !XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date)
495 set_frame_menubar (f, 1, 0);
497 run_hook (Qactivate_menubar_hook);
498 set_frame_menubar (f, 1, 0);
500 DEVICE_X_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
501 DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
502 x_focus_timestamp_really_sucks_fix_me_better;
506 static widget_value *
507 compute_menubar_data (struct frame *f, Lisp_Object menubar, int deep_p)
515 Lisp_Object old_buffer;
516 int count = specpdl_depth ();
518 old_buffer = Fcurrent_buffer ();
519 record_unwind_protect (Fset_buffer, old_buffer);
520 Fset_buffer ( XWINDOW (FRAME_SELECTED_WINDOW (f))->buffer);
521 data = menu_item_descriptor_to_widget_value (menubar, MENUBAR_TYPE,
523 Fset_buffer (old_buffer);
524 unbind_to (count, Qnil);
530 set_frame_menubar (struct frame *f, int deep_p, int first_time_p)
536 /* As for the toolbar, the minibuffer does not have its own menubar. */
537 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
542 /***** first compute the contents of the menubar *****/
546 /* evaluate `current-menubar' in the buffer of the selected window
547 of the frame in question. */
548 menubar = symbol_value_in_buffer (Qcurrent_menubar, w->buffer);
552 /* That's a little tricky the first time since the frame isn't
553 fully initialized yet. */
554 menubar = Fsymbol_value (Qcurrent_menubar);
559 menubar = Vblank_menubar;
563 menubar_visible = !NILP (w->menubar_visible_p);
565 data = compute_menubar_data (f, menubar, deep_p);
566 if (!data || (!data->next && !data->contents))
569 if (NILP (FRAME_MENUBAR_DATA (f)))
571 struct popup_data *mdata =
572 alloc_lcrecord_type (struct popup_data, lrecord_popup_data);
574 mdata->id = new_lwlib_id ();
575 mdata->last_menubar_buffer = Qnil;
576 mdata->menubar_contents_up_to_date = 0;
577 XSETPOPUP_DATA (FRAME_MENUBAR_DATA (f), mdata);
580 /***** now store into the menubar widget, creating it if necessary *****/
582 id = XFRAME_MENUBAR_DATA (f)->id;
583 if (!FRAME_X_MENUBAR_WIDGET (f))
585 Widget parent = FRAME_X_CONTAINER_WIDGET (f);
587 assert (first_time_p);
589 /* It's the first time we've mapped the menubar so compute its
590 contents completely once. This makes sure that the menubar
591 components are created with the right type. */
594 free_popup_widget_value_tree (data);
595 data = compute_menubar_data (f, menubar, 1);
599 FRAME_X_MENUBAR_WIDGET (f) =
600 lw_create_widget ("menubar", "menubar", id, data, parent,
601 0, pre_activate_callback,
602 popup_selection_callback, 0);
607 lw_modify_all_widgets (id, data, deep_p ? True : False);
609 free_popup_widget_value_tree (data);
611 XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date = deep_p;
612 XFRAME_MENUBAR_DATA (f)->last_menubar_buffer =
613 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer;
614 return menubar_visible;
618 /* Called from x_create_widgets() to create the inital menubar of a frame
619 before it is mapped, so that the window is mapped with the menubar already
620 there instead of us tacking it on later and thrashing the window after it
623 x_initialize_frame_menubar (struct frame *f)
625 return set_frame_menubar (f, 1, 1);
629 static LWLIB_ID last_popup_menu_selection_callback_id;
632 popup_menu_selection_callback (Widget widget, LWLIB_ID id,
633 XtPointer client_data)
635 last_popup_menu_selection_callback_id = id;
636 popup_selection_callback (widget, id, client_data);
637 /* lw_destroy_all_widgets() will be called from popup_down_callback() */
641 popup_menu_down_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
643 if (popup_handled_p (id))
645 assert (popup_up_p != 0);
646 ungcpro_popup_callbacks (id);
648 /* if this isn't called immediately after the selection callback, then
649 there wasn't a menu selection. */
650 if (id != last_popup_menu_selection_callback_id)
651 popup_selection_callback (widget, id, (XtPointer) -1);
652 lw_destroy_all_widgets (id);
657 make_dummy_xbutton_event (XEvent *dummy,
659 struct Lisp_Event *eev)
660 /* NULL for eev means query pointer */
662 XButtonPressedEvent *btn = (XButtonPressedEvent *) dummy;
664 btn->type = ButtonPress;
667 btn->display = XtDisplay (daddy);
668 btn->window = XtWindow (daddy);
671 Position shellx, shelly, framex, framey;
672 Widget shell = XtParent (daddy);
674 btn->time = eev->timestamp;
675 btn->button = eev->event.button.button;
676 btn->root = RootWindowOfScreen (XtScreen (daddy));
677 btn->subwindow = (Window) NULL;
678 btn->x = eev->event.button.x;
679 btn->y = eev->event.button.y;
680 XtSetArg (al [0], XtNx, &shellx);
681 XtSetArg (al [1], XtNy, &shelly);
682 XtGetValues (shell, al, 2);
683 XtSetArg (al [0], XtNx, &framex);
684 XtSetArg (al [1], XtNy, &framey);
685 XtGetValues (daddy, al, 2);
686 btn->x_root = shellx + framex + btn->x;
687 btn->y_root = shelly + framey + btn->y;;
688 btn->state = ButtonPressMask; /* all buttons pressed */
692 /* CurrentTime is just ZERO, so it's worthless for
693 determining relative click times. */
694 struct device *d = get_device_from_display (XtDisplay (daddy));
695 btn->time = DEVICE_X_MOUSE_TIMESTAMP (d); /* event-Xt maintains this */
697 XQueryPointer (btn->display, btn->window, &btn->root,
698 &btn->subwindow, &btn->x_root, &btn->y_root,
699 &btn->x, &btn->y, &btn->state);
706 x_update_frame_menubar_internal (struct frame *f)
708 /* We assume the menubar contents has changed if the global flag is set,
709 or if the current buffer has changed, or if the menubar has never
712 int menubar_contents_changed =
714 || NILP (FRAME_MENUBAR_DATA (f))
715 || (!EQ (XFRAME_MENUBAR_DATA (f)->last_menubar_buffer,
716 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer)));
718 Boolean menubar_was_visible = XtIsManaged (FRAME_X_MENUBAR_WIDGET (f));
719 Boolean menubar_will_be_visible = menubar_was_visible;
720 Boolean menubar_visibility_changed;
722 if (menubar_contents_changed)
723 menubar_will_be_visible = set_frame_menubar (f, 0, 0);
725 menubar_visibility_changed = menubar_was_visible != menubar_will_be_visible;
727 if (!menubar_visibility_changed)
730 /* Set menubar visibility */
731 (menubar_will_be_visible ? XtManageChild : XtUnmanageChild)
732 (FRAME_X_MENUBAR_WIDGET (f));
734 MARK_FRAME_SIZE_SLIPPED (f);
738 x_update_frame_menubars (struct frame *f)
740 assert (FRAME_X_P (f));
742 x_update_frame_menubar_internal (f);
744 /* #### This isn't going to work right now that this function works on
745 a per-frame, not per-device basis. Guess what? I don't care. */
749 x_free_frame_menubars (struct frame *f)
751 Widget menubar_widget;
753 assert (FRAME_X_P (f));
755 menubar_widget = FRAME_X_MENUBAR_WIDGET (f);
758 LWLIB_ID id = XFRAME_MENUBAR_DATA (f)->id;
759 lw_destroy_all_widgets (id);
760 XFRAME_MENUBAR_DATA (f)->id = 0;
765 x_popup_menu (Lisp_Object menu_desc, Lisp_Object event)
768 struct frame *f = selected_frame ();
772 struct Lisp_Event *eev = NULL;
776 XSETFRAME (frame, f);
777 CHECK_X_FRAME (frame);
778 parent = FRAME_X_SHELL_WIDGET (f);
782 CHECK_LIVE_EVENT (event);
784 if (eev->event_type != button_press_event
785 && eev->event_type != button_release_event)
786 wrong_type_argument (Qmouse_event_p, event);
788 else if (!NILP (Vthis_command_keys))
790 /* if an event wasn't passed, use the last event of the event sequence
791 currently being executed, if that event is a mouse event */
792 eev = XEVENT (Vthis_command_keys); /* last event first */
793 if (eev->event_type != button_press_event
794 && eev->event_type != button_release_event)
797 make_dummy_xbutton_event (&xev, parent, eev);
799 if (SYMBOLP (menu_desc))
800 menu_desc = Fsymbol_value (menu_desc);
801 CHECK_CONS (menu_desc);
802 CHECK_STRING (XCAR (menu_desc));
803 data = menu_item_descriptor_to_widget_value (menu_desc, POPUP_TYPE, 1, 1);
805 if (! data) error ("no menu");
807 menu_id = new_lwlib_id ();
808 menu = lw_create_widget ("popup", "popup" /* data->name */, menu_id, data,
810 popup_menu_selection_callback,
811 popup_menu_down_callback);
812 free_popup_widget_value_tree (data);
814 gcpro_popup_callbacks (menu_id);
816 /* Setting zmacs-region-stays is necessary here because executing a command
817 from a menu is really a two-command process: the first command (bound to
818 the button-click) simply pops up the menu, and returns. This causes a
819 sequence of magic-events (destined for the popup-menu widget) to begin.
820 Eventually, a menu item is selected, and a menu-event blip is pushed onto
821 the end of the input stream, which is then executed by the event loop.
823 So there are two command-events, with a bunch of magic-events between
824 them. We don't want the *first* command event to alter the state of the
825 region, so that the region can be available as an argument for the second
829 zmacs_region_stays = 1;
832 lw_popup_menu (menu, &xev);
833 /* this speeds up display of pop-up menus */
834 XFlush (XtDisplay (parent));
839 syms_of_menubar_x (void)
844 console_type_create_menubar_x (void)
846 CONSOLE_HAS_METHOD (x, update_frame_menubars);
847 CONSOLE_HAS_METHOD (x, free_frame_menubars);
848 CONSOLE_HAS_METHOD (x, popup_menu);
852 vars_of_menubar_x (void)
854 last_popup_menu_selection_callback_id = (LWLIB_ID) -1;
856 #if defined (LWLIB_MENUBARS_LUCID)
857 Fprovide (intern ("lucid-menubars"));
858 #elif defined (LWLIB_MENUBARS_MOTIF)
859 Fprovide (intern ("motif-menubars"));
860 #elif defined (LWLIB_MENUBARS_ATHENA)
861 Fprovide (intern ("athena-menubars"));