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 /* #### Sort of a hack needed to process Vactivate_menubar_hook
338 correctly wrt buffer-local values. A correct solution would
339 involve adding a callback mechanism to run_hook(). This function
340 is currently unused. */
342 my_run_hook (Lisp_Object hooksym, int allow_global_p)
344 /* This function can GC */
346 Lisp_Object value = Fsymbol_value (hooksym);
349 if (!NILP (value) && (!CONSP (value) || EQ (XCAR (value), Qlambda)))
350 return !EQ (call0 (value), Qt);
352 EXTERNAL_LIST_LOOP (tail, value)
354 if (allow_global_p && EQ (XCAR (tail), Qt))
355 changes |= my_run_hook (Fdefault_value (hooksym), 0);
356 if (!EQ (call0 (XCAR (tail)), Qt))
364 /* The order in which callbacks are run is funny to say the least.
365 It's sometimes tricky to avoid running a callback twice, and to
366 avoid returning prematurely. So, this function returns true
367 if the menu's callbacks are no longer gc protected. So long
368 as we unprotect them before allowing other callbacks to run,
369 everything should be ok.
371 The pre_activate_callback() *IS* intentionally called multiple times.
372 If client_data == NULL, then it's being called before the menu is posted.
373 If client_data != NULL, then client_data is a (widget_value *) and
374 client_data->data is a Lisp_Object pointing to a lisp submenu description
375 that must be converted into widget_values. *client_data is destructively
378 #### Stig thinks that there may be a GC problem here due to the
379 fact that pre_activate_callback() is called multiple times, but I
385 pre_activate_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
387 /* This function can GC */
388 struct device *d = get_device_from_display (XtDisplay (widget));
389 struct frame *f = x_any_window_to_frame (d, XtWindow (widget));
393 /* set in lwlib to the time stamp associated with the most recent menu
395 extern Time x_focus_timestamp_really_sucks_fix_me_better;
398 f = x_any_window_to_frame (d, XtWindow (XtParent (widget)));
402 /* make sure f is the selected frame */
403 XSETFRAME (frame, f);
404 Fselect_frame (frame);
408 /* this is an incremental menu construction callback */
409 widget_value *hack_wv = (widget_value *) client_data;
410 Lisp_Object submenu_desc;
413 assert (hack_wv->type == INCREMENTAL_TYPE);
414 VOID_TO_LISP (submenu_desc, hack_wv->call_data);
417 * #### Fix the menu code so this isn't necessary.
419 * Protect against reentering the menu code otherwise we will
420 * crash later when the code gets confused at the state
423 count = specpdl_depth ();
424 record_unwind_protect (restore_in_menu_callback,
425 make_int (in_menu_callback));
426 in_menu_callback = 1;
427 wv = menu_item_descriptor_to_widget_value (submenu_desc, SUBMENU_TYPE,
429 unbind_to (count, Qnil);
433 wv = xmalloc_widget_value ();
434 wv->type = CASCADE_TYPE;
436 wv->contents = xmalloc_widget_value ();
437 wv->contents->type = TEXT_TYPE;
438 wv->contents->name = (char *) "No menu";
439 wv->contents->next = NULL;
441 assert (wv && wv->type == CASCADE_TYPE && wv->contents);
442 replace_widget_value_tree (hack_wv, wv->contents);
443 free_popup_widget_value_tree (wv);
445 else if (!POPUP_DATAP (FRAME_MENUBAR_DATA (f)))
449 #if 0 /* Unused, see comment below. */
452 /* #### - this menubar update mechanism is expensively anti-social and
453 the activate-menubar-hook is now mostly obsolete. */
454 any_changes = my_run_hook (Qactivate_menubar_hook, 1);
456 /* #### - It is necessary to *ALWAYS* call set_frame_menubar() now that
457 incremental menus are implemented. If a subtree of a menu has been
458 updated incrementally (a destructive operation), then that subtree
459 must somehow be wiped.
461 It is difficult to undo the destructive operation in lwlib because
462 a pointer back to lisp data needs to be hidden away somewhere. So
463 that an INCREMENTAL_TYPE widget_value can be recreated... Hmmmmm. */
465 !XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date)
466 set_frame_menubar (f, 1, 0);
468 run_hook (Qactivate_menubar_hook);
469 set_frame_menubar (f, 1, 0);
471 DEVICE_X_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
472 DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
473 x_focus_timestamp_really_sucks_fix_me_better;
477 static widget_value *
478 compute_menubar_data (struct frame *f, Lisp_Object menubar, int deep_p)
486 Lisp_Object old_buffer;
487 int count = specpdl_depth ();
489 old_buffer = Fcurrent_buffer ();
490 record_unwind_protect (Fset_buffer, old_buffer);
491 Fset_buffer ( XWINDOW (FRAME_SELECTED_WINDOW (f))->buffer);
492 data = menu_item_descriptor_to_widget_value (menubar, MENUBAR_TYPE,
494 Fset_buffer (old_buffer);
495 unbind_to (count, Qnil);
501 set_frame_menubar (struct frame *f, int deep_p, int first_time_p)
507 /* As for the toolbar, the minibuffer does not have its own menubar. */
508 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
513 /***** first compute the contents of the menubar *****/
517 /* evaluate `current-menubar' in the buffer of the selected window
518 of the frame in question. */
519 menubar = symbol_value_in_buffer (Qcurrent_menubar, w->buffer);
523 /* That's a little tricky the first time since the frame isn't
524 fully initialized yet. */
525 menubar = Fsymbol_value (Qcurrent_menubar);
530 menubar = Vblank_menubar;
534 menubar_visible = !NILP (w->menubar_visible_p);
536 data = compute_menubar_data (f, menubar, deep_p);
537 if (!data || (!data->next && !data->contents))
540 if (NILP (FRAME_MENUBAR_DATA (f)))
542 struct popup_data *mdata =
543 alloc_lcrecord_type (struct popup_data, lrecord_popup_data);
545 mdata->id = new_lwlib_id ();
546 mdata->last_menubar_buffer = Qnil;
547 mdata->menubar_contents_up_to_date = 0;
548 XSETPOPUP_DATA (FRAME_MENUBAR_DATA (f), mdata);
551 /***** now store into the menubar widget, creating it if necessary *****/
553 id = XFRAME_MENUBAR_DATA (f)->id;
554 if (!FRAME_X_MENUBAR_WIDGET (f))
556 Widget parent = FRAME_X_CONTAINER_WIDGET (f);
558 assert (first_time_p);
560 /* It's the first time we've mapped the menubar so compute its
561 contents completely once. This makes sure that the menubar
562 components are created with the right type. */
565 free_popup_widget_value_tree (data);
566 data = compute_menubar_data (f, menubar, 1);
570 FRAME_X_MENUBAR_WIDGET (f) =
571 lw_create_widget ("menubar", "menubar", id, data, parent,
572 0, pre_activate_callback,
573 popup_selection_callback, 0);
578 lw_modify_all_widgets (id, data, deep_p ? True : False);
580 free_popup_widget_value_tree (data);
582 XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date = deep_p;
583 XFRAME_MENUBAR_DATA (f)->last_menubar_buffer =
584 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer;
585 return menubar_visible;
589 /* Called from x_create_widgets() to create the inital menubar of a frame
590 before it is mapped, so that the window is mapped with the menubar already
591 there instead of us tacking it on later and thrashing the window after it
594 x_initialize_frame_menubar (struct frame *f)
596 return set_frame_menubar (f, 1, 1);
600 static LWLIB_ID last_popup_menu_selection_callback_id;
603 popup_menu_selection_callback (Widget widget, LWLIB_ID id,
604 XtPointer client_data)
606 last_popup_menu_selection_callback_id = id;
607 popup_selection_callback (widget, id, client_data);
608 /* lw_destroy_all_widgets() will be called from popup_down_callback() */
612 popup_menu_down_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
614 if (popup_handled_p (id))
616 assert (popup_up_p != 0);
617 ungcpro_popup_callbacks (id);
619 /* if this isn't called immediately after the selection callback, then
620 there wasn't a menu selection. */
621 if (id != last_popup_menu_selection_callback_id)
622 popup_selection_callback (widget, id, (XtPointer) -1);
623 lw_destroy_all_widgets (id);
628 make_dummy_xbutton_event (XEvent *dummy,
630 struct Lisp_Event *eev)
631 /* NULL for eev means query pointer */
633 XButtonPressedEvent *btn = (XButtonPressedEvent *) dummy;
635 btn->type = ButtonPress;
638 btn->display = XtDisplay (daddy);
639 btn->window = XtWindow (daddy);
642 Position shellx, shelly, framex, framey;
643 Widget shell = XtParent (daddy);
645 btn->time = eev->timestamp;
646 btn->button = eev->event.button.button;
647 btn->root = RootWindowOfScreen (XtScreen (daddy));
648 btn->subwindow = (Window) NULL;
649 btn->x = eev->event.button.x;
650 btn->y = eev->event.button.y;
651 XtSetArg (al [0], XtNx, &shellx);
652 XtSetArg (al [1], XtNy, &shelly);
653 XtGetValues (shell, al, 2);
654 XtSetArg (al [0], XtNx, &framex);
655 XtSetArg (al [1], XtNy, &framey);
656 XtGetValues (daddy, al, 2);
657 btn->x_root = shellx + framex + btn->x;
658 btn->y_root = shelly + framey + btn->y;;
659 btn->state = ButtonPressMask; /* all buttons pressed */
663 /* CurrentTime is just ZERO, so it's worthless for
664 determining relative click times. */
665 struct device *d = get_device_from_display (XtDisplay (daddy));
666 btn->time = DEVICE_X_MOUSE_TIMESTAMP (d); /* event-Xt maintains this */
668 XQueryPointer (btn->display, btn->window, &btn->root,
669 &btn->subwindow, &btn->x_root, &btn->y_root,
670 &btn->x, &btn->y, &btn->state);
677 x_update_frame_menubar_internal (struct frame *f)
679 /* We assume the menubar contents has changed if the global flag is set,
680 or if the current buffer has changed, or if the menubar has never
683 int menubar_contents_changed =
685 || NILP (FRAME_MENUBAR_DATA (f))
686 || (!EQ (XFRAME_MENUBAR_DATA (f)->last_menubar_buffer,
687 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer)));
689 Boolean menubar_was_visible = XtIsManaged (FRAME_X_MENUBAR_WIDGET (f));
690 Boolean menubar_will_be_visible = menubar_was_visible;
691 Boolean menubar_visibility_changed;
693 if (menubar_contents_changed)
694 menubar_will_be_visible = set_frame_menubar (f, 0, 0);
696 menubar_visibility_changed = menubar_was_visible != menubar_will_be_visible;
698 if (!menubar_visibility_changed)
701 /* Set menubar visibility */
702 (menubar_will_be_visible ? XtManageChild : XtUnmanageChild)
703 (FRAME_X_MENUBAR_WIDGET (f));
705 MARK_FRAME_SIZE_SLIPPED (f);
709 x_update_frame_menubars (struct frame *f)
711 assert (FRAME_X_P (f));
713 x_update_frame_menubar_internal (f);
715 /* #### This isn't going to work right now that this function works on
716 a per-frame, not per-device basis. Guess what? I don't care. */
720 x_free_frame_menubars (struct frame *f)
722 Widget menubar_widget;
724 assert (FRAME_X_P (f));
726 menubar_widget = FRAME_X_MENUBAR_WIDGET (f);
729 LWLIB_ID id = XFRAME_MENUBAR_DATA (f)->id;
730 lw_destroy_all_widgets (id);
731 XFRAME_MENUBAR_DATA (f)->id = 0;
736 x_popup_menu (Lisp_Object menu_desc, Lisp_Object event)
739 struct frame *f = selected_frame ();
743 struct Lisp_Event *eev = NULL;
747 XSETFRAME (frame, f);
748 CHECK_X_FRAME (frame);
749 parent = FRAME_X_SHELL_WIDGET (f);
753 CHECK_LIVE_EVENT (event);
755 if (eev->event_type != button_press_event
756 && eev->event_type != button_release_event)
757 wrong_type_argument (Qmouse_event_p, event);
759 else if (!NILP (Vthis_command_keys))
761 /* if an event wasn't passed, use the last event of the event sequence
762 currently being executed, if that event is a mouse event */
763 eev = XEVENT (Vthis_command_keys); /* last event first */
764 if (eev->event_type != button_press_event
765 && eev->event_type != button_release_event)
768 make_dummy_xbutton_event (&xev, parent, eev);
770 if (SYMBOLP (menu_desc))
771 menu_desc = Fsymbol_value (menu_desc);
772 CHECK_CONS (menu_desc);
773 CHECK_STRING (XCAR (menu_desc));
774 data = menu_item_descriptor_to_widget_value (menu_desc, POPUP_TYPE, 1, 1);
776 if (! data) error ("no menu");
778 menu_id = new_lwlib_id ();
779 menu = lw_create_widget ("popup", "popup" /* data->name */, menu_id, data,
781 popup_menu_selection_callback,
782 popup_menu_down_callback);
783 free_popup_widget_value_tree (data);
785 gcpro_popup_callbacks (menu_id);
787 /* Setting zmacs-region-stays is necessary here because executing a command
788 from a menu is really a two-command process: the first command (bound to
789 the button-click) simply pops up the menu, and returns. This causes a
790 sequence of magic-events (destined for the popup-menu widget) to begin.
791 Eventually, a menu item is selected, and a menu-event blip is pushed onto
792 the end of the input stream, which is then executed by the event loop.
794 So there are two command-events, with a bunch of magic-events between
795 them. We don't want the *first* command event to alter the state of the
796 region, so that the region can be available as an argument for the second
800 zmacs_region_stays = 1;
803 lw_popup_menu (menu, &xev);
804 /* this speeds up display of pop-up menus */
805 XFlush (XtDisplay (parent));
810 syms_of_menubar_x (void)
815 console_type_create_menubar_x (void)
817 CONSOLE_HAS_METHOD (x, update_frame_menubars);
818 CONSOLE_HAS_METHOD (x, free_frame_menubars);
819 CONSOLE_HAS_METHOD (x, popup_menu);
823 vars_of_menubar_x (void)
825 last_popup_menu_selection_callback_id = (LWLIB_ID) -1;
827 #if defined (LWLIB_MENUBARS_LUCID)
828 Fprovide (intern ("lucid-menubars"));
829 #elif defined (LWLIB_MENUBARS_MOTIF)
830 Fprovide (intern ("motif-menubars"));
831 #elif defined (LWLIB_MENUBARS_ATHENA)
832 Fprovide (intern ("athena-menubars"));