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;
150 int included_spec = 0;
151 wv->type = CASCADE_TYPE;
153 wv->name = (char *) XSTRING_DATA (LISP_GETTEXT (XCAR (desc)));
155 accel = menu_name_to_accelerator (wv->name);
156 wv->accel = LISP_TO_VOID (accel);
160 while (key = Fcar (desc), KEYWORDP (key))
162 Lisp_Object cascade = desc;
165 signal_simple_error ("keyword in menu lacks a value",
169 if (EQ (key, Q_included))
170 include_p = val, included_spec = 1;
171 else if (EQ (key, Q_config))
173 else if (EQ (key, Q_filter))
175 else if (EQ (key, Q_accelerator))
179 wv->accel = LISP_TO_VOID (val);
181 signal_simple_error ("bad keyboard accelerator", val);
184 signal_simple_error ("unknown menu cascade keyword", cascade);
187 if ((!NILP (config_tag)
188 && NILP (Fmemq (config_tag, Vmenubar_configuration)))
189 || (included_spec && NILP (Feval (include_p))))
196 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
197 if (filter_p || depth == 0)
200 desc = call1_trapping_errors ("Error in menubar filter",
204 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
208 widget_value *incr_wv = xmalloc_widget_value ();
209 wv->contents = incr_wv;
210 incr_wv->type = INCREMENTAL_TYPE;
211 incr_wv->enabled = 1;
212 incr_wv->name = wv->name;
213 /* This is automatically GC protected through
214 the call to lw_map_widget_values(); no need
216 incr_wv->call_data = LISP_TO_VOID (incremental_data);
219 #endif /* LWLIB_MENUBARS_LUCID || LWLIB_MENUBARS_MOTIF */
221 if (menu_type == POPUP_TYPE && popup_menu_titles && depth == 0)
223 /* Simply prepend three more widget values to the contents of
224 the menu: a label, and two separators (to get a double
226 widget_value *title_wv = xmalloc_widget_value ();
227 widget_value *sep_wv = xmalloc_widget_value ();
228 title_wv->type = TEXT_TYPE;
229 title_wv->name = wv->name;
230 title_wv->enabled = 1;
231 title_wv->next = sep_wv;
232 sep_wv->type = SEPARATOR_TYPE;
233 sep_wv->value = menu_separator_style ("==");
236 wv->contents = title_wv;
240 else if (menubar_root_p)
242 wv->name = (char *) "menubar";
243 wv->type = CASCADE_TYPE; /* Well, nothing else seems to fit and
244 this is ignored anyway... */
248 signal_simple_error ("menu name (first element) must be a string",
253 if (deep_p || menubar_root_p)
256 for (; !NILP (desc); desc = Fcdr (desc))
258 Lisp_Object child = Fcar (desc);
259 if (menubar_root_p && NILP (child)) /* the partition */
263 "more than one partition (nil) in menubar description");
265 next = xmalloc_widget_value ();
266 next->type = PUSHRIGHT_TYPE;
270 next = menu_item_descriptor_to_widget_value_1
271 (child, menu_type, deep_p, filter_p, depth + 1);
282 if (deep_p && !wv->contents)
285 else if (NILP (desc))
286 error ("nil may not appear in menu descriptions");
288 signal_simple_error ("unrecognized menu descriptor", desc);
294 /* Completed normally. Clear out the object that widget_value_unwind()
295 will be called with to tell it not to free the wv (as we are
297 set_opaque_ptr (wv_closure, 0);
300 unbind_to (count, Qnil);
304 static widget_value *
305 menu_item_descriptor_to_widget_value (Lisp_Object desc,
306 int menu_type, /* if this is a menubar,
309 int filter_p) /* if :filter forms
313 int count = specpdl_depth ();
314 record_unwind_protect (restore_gc_inhibit,
315 make_int (gc_currently_forbidden));
316 gc_currently_forbidden = 1;
318 wv = menu_item_descriptor_to_widget_value_1 (desc, menu_type, deep_p,
320 unbind_to (count, Qnil);
325 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
326 int in_menu_callback;
329 restore_in_menu_callback (Lisp_Object val)
331 in_menu_callback = XINT(val);
334 #endif /* LWLIB_MENUBARS_LUCID || LWLIB_MENUBARS_MOTIF */
337 /* The order in which callbacks are run is funny to say the least.
338 It's sometimes tricky to avoid running a callback twice, and to
339 avoid returning prematurely. So, this function returns true
340 if the menu's callbacks are no longer gc protected. So long
341 as we unprotect them before allowing other callbacks to run,
342 everything should be ok.
344 The pre_activate_callback() *IS* intentionally called multiple times.
345 If client_data == NULL, then it's being called before the menu is posted.
346 If client_data != NULL, then client_data is a (widget_value *) and
347 client_data->data is a Lisp_Object pointing to a lisp submenu description
348 that must be converted into widget_values. *client_data is destructively
351 #### Stig thinks that there may be a GC problem here due to the
352 fact that pre_activate_callback() is called multiple times, but I
358 pre_activate_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
360 /* This function can GC */
362 struct device *d = get_device_from_display (XtDisplay (widget));
363 struct frame *f = x_any_window_to_frame (d, XtWindow (widget));
364 Lisp_Object rest = Qnil;
369 /* set in lwlib to the time stamp associated with the most recent menu
371 extern Time x_focus_timestamp_really_sucks_fix_me_better;
374 f = x_any_window_to_frame (d, XtWindow (XtParent (widget)));
378 /* make sure f is the selected frame */
379 XSETFRAME (frame, f);
380 Fselect_frame (frame);
384 /* this is an incremental menu construction callback */
385 widget_value *hack_wv = (widget_value *) client_data;
386 Lisp_Object submenu_desc;
389 assert (hack_wv->type == INCREMENTAL_TYPE);
390 VOID_TO_LISP (submenu_desc, hack_wv->call_data);
393 * #### Fix the menu code so this isn't necessary.
395 * Protect against reentering the menu code otherwise we will
396 * crash later when the code gets confused at the state
399 count = specpdl_depth ();
400 record_unwind_protect (restore_in_menu_callback,
401 make_int (in_menu_callback));
402 in_menu_callback = 1;
403 wv = menu_item_descriptor_to_widget_value (submenu_desc, SUBMENU_TYPE,
405 unbind_to (count, Qnil);
409 wv = xmalloc_widget_value ();
410 wv->type = CASCADE_TYPE;
412 wv->contents = xmalloc_widget_value ();
413 wv->contents->type = TEXT_TYPE;
414 wv->contents->name = (char *) "No menu";
415 wv->contents->next = NULL;
417 assert (wv && wv->type == CASCADE_TYPE && wv->contents);
418 replace_widget_value_tree (hack_wv, wv->contents);
419 free_popup_widget_value_tree (wv);
423 if (!POPUP_DATAP (FRAME_MENUBAR_DATA (f)))
425 /* #### - this menubar update mechanism is expensively anti-social and
426 the activate-menubar-hook is now mostly obsolete. */
427 /* make the activate-menubar-hook be a list of functions, not a single
428 function, just to simplify things. */
429 if (!NILP (Vactivate_menubar_hook) &&
430 (!CONSP (Vactivate_menubar_hook) ||
431 EQ (XCAR (Vactivate_menubar_hook), Qlambda)))
432 Vactivate_menubar_hook = Fcons (Vactivate_menubar_hook, Qnil);
435 for (rest = Vactivate_menubar_hook; !NILP (rest); rest = Fcdr (rest))
436 if (!EQ (call0 (XCAR (rest)), Qt))
439 /* #### - It is necessary to *ALWAYS* call set_frame_menubar() now that
440 incremental menus are implemented. If a subtree of a menu has been
441 updated incrementally (a destructive operation), then that subtree
442 must somehow be wiped.
444 It is difficult to undo the destructive operation in lwlib because
445 a pointer back to lisp data needs to be hidden away somewhere. So
446 that an INCREMENTAL_TYPE widget_value can be recreated... Hmmmmm. */
448 !XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date)
450 set_frame_menubar (f, 1, 0);
451 DEVICE_X_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
452 DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
453 x_focus_timestamp_really_sucks_fix_me_better;
458 static widget_value *
459 compute_menubar_data (struct frame *f, Lisp_Object menubar, int deep_p)
467 Lisp_Object old_buffer;
468 int count = specpdl_depth ();
470 old_buffer = Fcurrent_buffer ();
471 record_unwind_protect (Fset_buffer, old_buffer);
472 Fset_buffer ( XWINDOW (FRAME_SELECTED_WINDOW (f))->buffer);
473 data = menu_item_descriptor_to_widget_value (menubar, MENUBAR_TYPE,
475 Fset_buffer (old_buffer);
476 unbind_to (count, Qnil);
482 set_frame_menubar (struct frame *f, int deep_p, int first_time_p)
488 /* As for the toolbar, the minibuffer does not have its own menubar. */
489 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
494 /***** first compute the contents of the menubar *****/
498 /* evaluate `current-menubar' in the buffer of the selected window
499 of the frame in question. */
500 menubar = symbol_value_in_buffer (Qcurrent_menubar, w->buffer);
504 /* That's a little tricky the first time since the frame isn't
505 fully initialized yet. */
506 menubar = Fsymbol_value (Qcurrent_menubar);
511 menubar = Vblank_menubar;
515 menubar_visible = !NILP (w->menubar_visible_p);
517 data = compute_menubar_data (f, menubar, deep_p);
518 if (!data || (!data->next && !data->contents))
521 if (NILP (FRAME_MENUBAR_DATA (f)))
523 struct popup_data *mdata =
524 alloc_lcrecord_type (struct popup_data, lrecord_popup_data);
526 mdata->id = new_lwlib_id ();
527 mdata->last_menubar_buffer = Qnil;
528 mdata->menubar_contents_up_to_date = 0;
529 XSETPOPUP_DATA (FRAME_MENUBAR_DATA (f), mdata);
532 /***** now store into the menubar widget, creating it if necessary *****/
534 id = XFRAME_MENUBAR_DATA (f)->id;
535 if (!FRAME_X_MENUBAR_WIDGET (f))
537 Widget parent = FRAME_X_CONTAINER_WIDGET (f);
539 assert (first_time_p);
541 /* It's the first time we've mapped the menubar so compute its
542 contents completely once. This makes sure that the menubar
543 components are created with the right type. */
546 free_popup_widget_value_tree (data);
547 data = compute_menubar_data (f, menubar, 1);
551 FRAME_X_MENUBAR_WIDGET (f) =
552 lw_create_widget ("menubar", "menubar", id, data, parent,
553 0, pre_activate_callback,
554 popup_selection_callback, 0);
559 lw_modify_all_widgets (id, data, deep_p ? True : False);
561 free_popup_widget_value_tree (data);
563 XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date = deep_p;
564 XFRAME_MENUBAR_DATA (f)->last_menubar_buffer =
565 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer;
566 return menubar_visible;
570 /* Called from x_create_widgets() to create the inital menubar of a frame
571 before it is mapped, so that the window is mapped with the menubar already
572 there instead of us tacking it on later and thrashing the window after it
575 x_initialize_frame_menubar (struct frame *f)
577 return set_frame_menubar (f, 1, 1);
581 static LWLIB_ID last_popup_menu_selection_callback_id;
584 popup_menu_selection_callback (Widget widget, LWLIB_ID id,
585 XtPointer client_data)
587 last_popup_menu_selection_callback_id = id;
588 popup_selection_callback (widget, id, client_data);
589 /* lw_destroy_all_widgets() will be called from popup_down_callback() */
593 popup_menu_down_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
595 if (popup_handled_p (id))
597 assert (popup_up_p != 0);
598 ungcpro_popup_callbacks (id);
600 /* if this isn't called immediately after the selection callback, then
601 there wasn't a menu selection. */
602 if (id != last_popup_menu_selection_callback_id)
603 popup_selection_callback (widget, id, (XtPointer) -1);
604 lw_destroy_all_widgets (id);
609 make_dummy_xbutton_event (XEvent *dummy,
611 struct Lisp_Event *eev)
612 /* NULL for eev means query pointer */
614 XButtonPressedEvent *btn = (XButtonPressedEvent *) dummy;
616 btn->type = ButtonPress;
619 btn->display = XtDisplay (daddy);
620 btn->window = XtWindow (daddy);
623 Position shellx, shelly, framex, framey;
624 Widget shell = XtParent (daddy);
626 btn->time = eev->timestamp;
627 btn->button = eev->event.button.button;
628 btn->root = RootWindowOfScreen (XtScreen (daddy));
629 btn->subwindow = (Window) NULL;
630 btn->x = eev->event.button.x;
631 btn->y = eev->event.button.y;
632 XtSetArg (al [0], XtNx, &shellx);
633 XtSetArg (al [1], XtNy, &shelly);
634 XtGetValues (shell, al, 2);
635 XtSetArg (al [0], XtNx, &framex);
636 XtSetArg (al [1], XtNy, &framey);
637 XtGetValues (daddy, al, 2);
638 btn->x_root = shellx + framex + btn->x;
639 btn->y_root = shelly + framey + btn->y;;
640 btn->state = ButtonPressMask; /* all buttons pressed */
644 /* CurrentTime is just ZERO, so it's worthless for
645 determining relative click times. */
646 struct device *d = get_device_from_display (XtDisplay (daddy));
647 btn->time = DEVICE_X_MOUSE_TIMESTAMP (d); /* event-Xt maintains this */
649 XQueryPointer (btn->display, btn->window, &btn->root,
650 &btn->subwindow, &btn->x_root, &btn->y_root,
651 &btn->x, &btn->y, &btn->state);
658 x_update_frame_menubar_internal (struct frame *f)
660 /* We assume the menubar contents has changed if the global flag is set,
661 or if the current buffer has changed, or if the menubar has never
664 int menubar_contents_changed =
666 || NILP (FRAME_MENUBAR_DATA (f))
667 || (!EQ (XFRAME_MENUBAR_DATA (f)->last_menubar_buffer,
668 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer)));
670 Boolean menubar_was_visible = XtIsManaged (FRAME_X_MENUBAR_WIDGET (f));
671 Boolean menubar_will_be_visible = menubar_was_visible;
672 Boolean menubar_visibility_changed;
674 if (menubar_contents_changed)
675 menubar_will_be_visible = set_frame_menubar (f, 0, 0);
677 menubar_visibility_changed = menubar_was_visible != menubar_will_be_visible;
679 if (!menubar_visibility_changed)
682 /* Set menubar visibility */
683 (menubar_will_be_visible ? XtManageChild : XtUnmanageChild)
684 (FRAME_X_MENUBAR_WIDGET (f));
686 MARK_FRAME_SIZE_SLIPPED (f);
690 x_update_frame_menubars (struct frame *f)
692 assert (FRAME_X_P (f));
694 x_update_frame_menubar_internal (f);
696 /* #### This isn't going to work right now that this function works on
697 a per-frame, not per-device basis. Guess what? I don't care. */
701 x_free_frame_menubars (struct frame *f)
703 Widget menubar_widget;
705 assert (FRAME_X_P (f));
707 menubar_widget = FRAME_X_MENUBAR_WIDGET (f);
710 LWLIB_ID id = XFRAME_MENUBAR_DATA (f)->id;
711 lw_destroy_all_widgets (id);
712 XFRAME_MENUBAR_DATA (f)->id = 0;
717 x_popup_menu (Lisp_Object menu_desc, Lisp_Object event)
720 struct frame *f = selected_frame ();
724 struct Lisp_Event *eev = NULL;
728 XSETFRAME (frame, f);
729 CHECK_X_FRAME (frame);
730 parent = FRAME_X_SHELL_WIDGET (f);
734 CHECK_LIVE_EVENT (event);
736 if (eev->event_type != button_press_event
737 && eev->event_type != button_release_event)
738 wrong_type_argument (Qmouse_event_p, event);
740 else if (!NILP (Vthis_command_keys))
742 /* if an event wasn't passed, use the last event of the event sequence
743 currently being executed, if that event is a mouse event */
744 eev = XEVENT (Vthis_command_keys); /* last event first */
745 if (eev->event_type != button_press_event
746 && eev->event_type != button_release_event)
749 make_dummy_xbutton_event (&xev, parent, eev);
751 if (SYMBOLP (menu_desc))
752 menu_desc = Fsymbol_value (menu_desc);
753 CHECK_CONS (menu_desc);
754 CHECK_STRING (XCAR (menu_desc));
755 data = menu_item_descriptor_to_widget_value (menu_desc, POPUP_TYPE, 1, 1);
757 if (! data) error ("no menu");
759 menu_id = new_lwlib_id ();
760 menu = lw_create_widget ("popup", "popup" /* data->name */, menu_id, data,
762 popup_menu_selection_callback,
763 popup_menu_down_callback);
764 free_popup_widget_value_tree (data);
766 gcpro_popup_callbacks (menu_id);
768 /* Setting zmacs-region-stays is necessary here because executing a command
769 from a menu is really a two-command process: the first command (bound to
770 the button-click) simply pops up the menu, and returns. This causes a
771 sequence of magic-events (destined for the popup-menu widget) to begin.
772 Eventually, a menu item is selected, and a menu-event blip is pushed onto
773 the end of the input stream, which is then executed by the event loop.
775 So there are two command-events, with a bunch of magic-events between
776 them. We don't want the *first* command event to alter the state of the
777 region, so that the region can be available as an argument for the second
781 zmacs_region_stays = 1;
784 lw_popup_menu (menu, &xev);
785 /* this speeds up display of pop-up menus */
786 XFlush (XtDisplay (parent));
791 syms_of_menubar_x (void)
796 console_type_create_menubar_x (void)
798 CONSOLE_HAS_METHOD (x, update_frame_menubars);
799 CONSOLE_HAS_METHOD (x, free_frame_menubars);
800 CONSOLE_HAS_METHOD (x, popup_menu);
804 vars_of_menubar_x (void)
806 last_popup_menu_selection_callback_id = (LWLIB_ID) -1;
808 #if defined (LWLIB_MENUBARS_LUCID)
809 Fprovide (intern ("lucid-menubars"));
810 #elif defined (LWLIB_MENUBARS_MOTIF)
811 Fprovide (intern ("motif-menubars"));
812 #elif defined (LWLIB_MENUBARS_ATHENA)
813 Fprovide (intern ("athena-menubars"));