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 "EmacsFrame.h"
34 #include "commands.h" /* zmacs_regions */
41 static int set_frame_menubar (struct frame *f,
45 #define FRAME_MENUBAR_DATA(frame) ((frame)->menubar_data)
46 #define XFRAME_MENUBAR_DATA(frame) XPOPUP_DATA ((frame)->menubar_data)
48 #define MENUBAR_TYPE 0
49 #define SUBMENU_TYPE 1
53 /* Converting Lisp menu tree descriptions to lwlib's `widget_value' form.
55 menu_item_descriptor_to_widget_value() converts a lisp description of a
56 menubar into a tree of widget_value structures. It allocates widget_values
57 with malloc_widget_value() and allocates other storage only for the `key'
58 slot. All other slots are filled with pointers to Lisp_String data. We
59 allocate a widget_value description of the menu or menubar, and hand it to
60 lwlib, which then makes a copy of it, which it manages internally. We then
61 immediately free our widget_value tree; it will not be referenced again.
63 Incremental menu construction callbacks operate just a bit differently.
64 They allocate widget_values and call replace_widget_value_tree() to tell
65 lwlib to destructively modify the incremental stub (subtree) of its
66 separate widget_value tree.
68 This function is highly recursive (it follows the menu trees) and may call
69 eval. The reason we keep pointers to lisp string data instead of copying
70 it and freeing it later is to avoid the speed penalty that would entail
71 (since this needs to be fast, in the simple cases at least). (The reason
72 we malloc/free the keys slot is because there's not a lisp string around
73 for us to use in that case.)
75 Since we keep pointers to lisp strings, and we call eval, we could lose if
76 GC relocates (or frees) those strings. It's not easy to gc protect the
77 strings because of the recursive nature of this function, and the fact that
78 it returns a data structure that gets freed later. So... we do the
79 sleaziest thing possible and inhibit GC for the duration. This is probably
82 We do not have to worry about the pointers to Lisp_String data after
83 this function successfully finishes. lwlib copies all such data with
87 menu_item_descriptor_to_widget_value_1 (Lisp_Object desc,
88 int menu_type, int deep_p,
92 /* This function cannot GC.
93 It is only called from menu_item_descriptor_to_widget_value, which
95 /* !!#### This function has not been Mule-ized */
96 int menubar_root_p = (menu_type == MENUBAR_TYPE && depth == 0);
98 Lisp_Object wv_closure;
99 int count = specpdl_depth ();
100 int partition_seen = 0;
102 wv = xmalloc_widget_value ();
104 wv_closure = make_opaque_ptr (wv);
105 record_unwind_protect (widget_value_unwind, wv_closure);
109 char *string_chars = (char *) XSTRING_DATA (desc);
110 wv->type = (separator_string_p (string_chars) ? SEPARATOR_TYPE :
113 /* #### - should internationalize with X resources instead.
115 string_chars = GETTEXT (string_chars);
117 if (wv->type == SEPARATOR_TYPE)
119 wv->value = menu_separator_style (string_chars);
123 wv->name = string_chars;
127 else if (VECTORP (desc))
129 if (!button_item_to_widget_value (desc, wv, 1,
130 (menu_type == MENUBAR_TYPE
133 /* :included form was nil */
138 else if (CONSP (desc))
140 Lisp_Object incremental_data = desc;
141 widget_value *prev = 0;
143 if (STRINGP (XCAR (desc)))
145 Lisp_Object key, val;
146 Lisp_Object include_p = Qnil, hook_fn = Qnil, config_tag = Qnil;
147 Lisp_Object active_p = Qt;
149 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_active))
176 active_p = val, active_spec = 1;
177 else if (EQ (key, Q_accelerator))
181 wv->accel = LISP_TO_VOID (val);
183 signal_simple_error ("bad keyboard accelerator", val);
185 else if (EQ (key, Q_label))
187 /* implement in 21.2 */
190 signal_simple_error ("Unknown menu cascade keyword", cascade);
193 if ((!NILP (config_tag)
194 && NILP (Fmemq (config_tag, Vmenubar_configuration)))
195 || (included_spec && NILP (Feval (include_p))))
202 active_p = Feval (active_p);
204 if (!NILP (hook_fn) && !NILP (active_p))
206 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
207 if (filter_p || depth == 0)
210 desc = call1_trapping_errors ("Error in menubar filter",
214 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
218 widget_value *incr_wv = xmalloc_widget_value ();
219 wv->contents = incr_wv;
220 incr_wv->type = INCREMENTAL_TYPE;
221 incr_wv->enabled = 1;
222 incr_wv->name = wv->name;
223 /* This is automatically GC protected through
224 the call to lw_map_widget_values(); no need
226 incr_wv->call_data = LISP_TO_VOID (incremental_data);
229 #endif /* LWLIB_MENUBARS_LUCID || LWLIB_MENUBARS_MOTIF */
231 if (menu_type == POPUP_TYPE && popup_menu_titles && depth == 0)
233 /* Simply prepend three more widget values to the contents of
234 the menu: a label, and two separators (to get a double
236 widget_value *title_wv = xmalloc_widget_value ();
237 widget_value *sep_wv = xmalloc_widget_value ();
238 title_wv->type = TEXT_TYPE;
239 title_wv->name = wv->name;
240 title_wv->enabled = 1;
241 title_wv->next = sep_wv;
242 sep_wv->type = SEPARATOR_TYPE;
243 sep_wv->value = menu_separator_style ("==");
246 wv->contents = title_wv;
249 wv->enabled = ! NILP (active_p);
250 if (deep_p && !wv->enabled && !NILP (desc))
253 /* Add a fake entry so the menus show up */
254 wv->contents = dummy = xmalloc_widget_value ();
255 dummy->name = "(inactive)";
256 dummy->accel = LISP_TO_VOID (Qnil);
260 dummy->type = BUTTON_TYPE;
261 dummy->call_data = NULL;
268 else if (menubar_root_p)
270 wv->name = (char *) "menubar";
271 wv->type = CASCADE_TYPE; /* Well, nothing else seems to fit and
272 this is ignored anyway... */
276 signal_simple_error ("Menu name (first element) must be a string",
280 if (deep_p || menubar_root_p)
283 for (; !NILP (desc); desc = Fcdr (desc))
285 Lisp_Object child = Fcar (desc);
286 if (menubar_root_p && NILP (child)) /* the partition */
290 "More than one partition (nil) in menubar description");
292 next = xmalloc_widget_value ();
293 next->type = PUSHRIGHT_TYPE;
297 next = menu_item_descriptor_to_widget_value_1
298 (child, menu_type, deep_p, filter_p, depth + 1);
309 if (deep_p && !wv->contents)
312 else if (NILP (desc))
313 error ("nil may not appear in menu descriptions");
315 signal_simple_error ("Unrecognized menu descriptor", desc);
321 /* Completed normally. Clear out the object that widget_value_unwind()
322 will be called with to tell it not to free the wv (as we are
324 set_opaque_ptr (wv_closure, 0);
327 unbind_to (count, Qnil);
331 static widget_value *
332 menu_item_descriptor_to_widget_value (Lisp_Object desc,
333 int menu_type, /* if this is a menubar,
336 int filter_p) /* if :filter forms
340 int count = specpdl_depth ();
341 record_unwind_protect (restore_gc_inhibit,
342 make_int (gc_currently_forbidden));
343 gc_currently_forbidden = 1;
345 wv = menu_item_descriptor_to_widget_value_1 (desc, menu_type, deep_p,
347 unbind_to (count, Qnil);
352 #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
353 int in_menu_callback;
356 restore_in_menu_callback (Lisp_Object val)
358 in_menu_callback = XINT(val);
361 #endif /* LWLIB_MENUBARS_LUCID || LWLIB_MENUBARS_MOTIF */
364 /* #### Sort of a hack needed to process Vactivate_menubar_hook
365 correctly wrt buffer-local values. A correct solution would
366 involve adding a callback mechanism to run_hook(). This function
367 is currently unused. */
369 my_run_hook (Lisp_Object hooksym, int allow_global_p)
371 /* This function can GC */
373 Lisp_Object value = Fsymbol_value (hooksym);
376 if (!NILP (value) && (!CONSP (value) || EQ (XCAR (value), Qlambda)))
377 return !EQ (call0 (value), Qt);
379 EXTERNAL_LIST_LOOP (tail, value)
381 if (allow_global_p && EQ (XCAR (tail), Qt))
382 changes |= my_run_hook (Fdefault_value (hooksym), 0);
383 if (!EQ (call0 (XCAR (tail)), Qt))
391 /* The order in which callbacks are run is funny to say the least.
392 It's sometimes tricky to avoid running a callback twice, and to
393 avoid returning prematurely. So, this function returns true
394 if the menu's callbacks are no longer gc protected. So long
395 as we unprotect them before allowing other callbacks to run,
396 everything should be ok.
398 The pre_activate_callback() *IS* intentionally called multiple times.
399 If client_data == NULL, then it's being called before the menu is posted.
400 If client_data != NULL, then client_data is a (widget_value *) and
401 client_data->data is a Lisp_Object pointing to a lisp submenu description
402 that must be converted into widget_values. *client_data is destructively
405 #### Stig thinks that there may be a GC problem here due to the
406 fact that pre_activate_callback() is called multiple times, but I
412 pre_activate_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
414 /* This function can GC */
415 struct device *d = get_device_from_display (XtDisplay (widget));
416 struct frame *f = x_any_window_to_frame (d, XtWindow (widget));
420 /* set in lwlib to the time stamp associated with the most recent menu
422 extern Time x_focus_timestamp_really_sucks_fix_me_better;
425 f = x_any_window_to_frame (d, XtWindow (XtParent (widget)));
429 /* make sure f is the selected frame */
430 XSETFRAME (frame, f);
431 Fselect_frame (frame);
435 /* this is an incremental menu construction callback */
436 widget_value *hack_wv = (widget_value *) client_data;
437 Lisp_Object submenu_desc;
440 assert (hack_wv->type == INCREMENTAL_TYPE);
441 VOID_TO_LISP (submenu_desc, hack_wv->call_data);
444 * #### Fix the menu code so this isn't necessary.
446 * Protect against reentering the menu code otherwise we will
447 * crash later when the code gets confused at the state
450 count = specpdl_depth ();
451 record_unwind_protect (restore_in_menu_callback,
452 make_int (in_menu_callback));
453 in_menu_callback = 1;
454 wv = menu_item_descriptor_to_widget_value (submenu_desc, SUBMENU_TYPE,
456 unbind_to (count, Qnil);
460 wv = xmalloc_widget_value ();
461 wv->type = CASCADE_TYPE;
463 wv->contents = xmalloc_widget_value ();
464 wv->contents->type = TEXT_TYPE;
465 wv->contents->name = (char *) "No menu";
466 wv->contents->next = NULL;
468 assert (wv && wv->type == CASCADE_TYPE && wv->contents);
469 replace_widget_value_tree (hack_wv, wv->contents);
470 free_popup_widget_value_tree (wv);
472 else if (!POPUP_DATAP (FRAME_MENUBAR_DATA (f)))
476 #if 0 /* Unused, see comment below. */
479 /* #### - this menubar update mechanism is expensively anti-social and
480 the activate-menubar-hook is now mostly obsolete. */
481 any_changes = my_run_hook (Qactivate_menubar_hook, 1);
483 /* #### - It is necessary to *ALWAYS* call set_frame_menubar() now that
484 incremental menus are implemented. If a subtree of a menu has been
485 updated incrementally (a destructive operation), then that subtree
486 must somehow be wiped.
488 It is difficult to undo the destructive operation in lwlib because
489 a pointer back to lisp data needs to be hidden away somewhere. So
490 that an INCREMENTAL_TYPE widget_value can be recreated... Hmmmmm. */
492 !XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date)
493 set_frame_menubar (f, 1, 0);
495 run_hook (Qactivate_menubar_hook);
496 set_frame_menubar (f, 1, 0);
498 DEVICE_X_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
499 DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
500 x_focus_timestamp_really_sucks_fix_me_better;
504 static widget_value *
505 compute_menubar_data (struct frame *f, Lisp_Object menubar, int deep_p)
513 Lisp_Object old_buffer;
514 int count = specpdl_depth ();
516 old_buffer = Fcurrent_buffer ();
517 record_unwind_protect (Fset_buffer, old_buffer);
518 Fset_buffer ( XWINDOW (FRAME_SELECTED_WINDOW (f))->buffer);
519 data = menu_item_descriptor_to_widget_value (menubar, MENUBAR_TYPE,
521 Fset_buffer (old_buffer);
522 unbind_to (count, Qnil);
528 set_frame_menubar (struct frame *f, int deep_p, int first_time_p)
534 /* As for the toolbar, the minibuffer does not have its own menubar. */
535 struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f));
540 /***** first compute the contents of the menubar *****/
544 /* evaluate `current-menubar' in the buffer of the selected window
545 of the frame in question. */
546 menubar = symbol_value_in_buffer (Qcurrent_menubar, w->buffer);
550 /* That's a little tricky the first time since the frame isn't
551 fully initialized yet. */
552 menubar = Fsymbol_value (Qcurrent_menubar);
557 menubar = Vblank_menubar;
561 menubar_visible = !NILP (w->menubar_visible_p);
563 data = compute_menubar_data (f, menubar, deep_p);
564 if (!data || (!data->next && !data->contents))
567 if (NILP (FRAME_MENUBAR_DATA (f)))
569 struct popup_data *mdata =
570 alloc_lcrecord_type (struct popup_data, lrecord_popup_data);
572 mdata->id = new_lwlib_id ();
573 mdata->last_menubar_buffer = Qnil;
574 mdata->menubar_contents_up_to_date = 0;
575 XSETPOPUP_DATA (FRAME_MENUBAR_DATA (f), mdata);
578 /***** now store into the menubar widget, creating it if necessary *****/
580 id = XFRAME_MENUBAR_DATA (f)->id;
581 if (!FRAME_X_MENUBAR_WIDGET (f))
583 Widget parent = FRAME_X_CONTAINER_WIDGET (f);
585 assert (first_time_p);
587 /* It's the first time we've mapped the menubar so compute its
588 contents completely once. This makes sure that the menubar
589 components are created with the right type. */
592 free_popup_widget_value_tree (data);
593 data = compute_menubar_data (f, menubar, 1);
597 FRAME_X_MENUBAR_WIDGET (f) =
598 lw_create_widget ("menubar", "menubar", id, data, parent,
599 0, pre_activate_callback,
600 popup_selection_callback, 0);
605 lw_modify_all_widgets (id, data, deep_p ? True : False);
607 free_popup_widget_value_tree (data);
609 XFRAME_MENUBAR_DATA (f)->menubar_contents_up_to_date = deep_p;
610 XFRAME_MENUBAR_DATA (f)->last_menubar_buffer =
611 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer;
612 return menubar_visible;
616 /* Called from x_create_widgets() to create the initial menubar of a frame
617 before it is mapped, so that the window is mapped with the menubar already
618 there instead of us tacking it on later and thrashing the window after it
621 x_initialize_frame_menubar (struct frame *f)
623 return set_frame_menubar (f, 1, 1);
627 static LWLIB_ID last_popup_menu_selection_callback_id;
630 popup_menu_selection_callback (Widget widget, LWLIB_ID id,
631 XtPointer client_data)
633 last_popup_menu_selection_callback_id = id;
634 popup_selection_callback (widget, id, client_data);
635 /* lw_destroy_all_widgets() will be called from popup_down_callback() */
639 popup_menu_down_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
641 if (popup_handled_p (id))
643 assert (popup_up_p != 0);
644 ungcpro_popup_callbacks (id);
646 /* if this isn't called immediately after the selection callback, then
647 there wasn't a menu selection. */
648 if (id != last_popup_menu_selection_callback_id)
649 popup_selection_callback (widget, id, (XtPointer) -1);
650 lw_destroy_all_widgets (id);
655 make_dummy_xbutton_event (XEvent *dummy,
657 struct Lisp_Event *eev)
658 /* NULL for eev means query pointer */
660 XButtonPressedEvent *btn = (XButtonPressedEvent *) dummy;
662 btn->type = ButtonPress;
665 btn->display = XtDisplay (daddy);
666 btn->window = XtWindow (daddy);
669 Position shellx, shelly, framex, framey;
670 Widget shell = XtParent (daddy);
672 btn->time = eev->timestamp;
673 btn->button = eev->event.button.button;
674 btn->root = RootWindowOfScreen (XtScreen (daddy));
675 btn->subwindow = (Window) NULL;
676 btn->x = eev->event.button.x;
677 btn->y = eev->event.button.y;
678 XtSetArg (al [0], XtNx, &shellx);
679 XtSetArg (al [1], XtNy, &shelly);
680 XtGetValues (shell, al, 2);
681 XtSetArg (al [0], XtNx, &framex);
682 XtSetArg (al [1], XtNy, &framey);
683 XtGetValues (daddy, al, 2);
684 btn->x_root = shellx + framex + btn->x;
685 btn->y_root = shelly + framey + btn->y;
686 btn->state = ButtonPressMask; /* all buttons pressed */
690 /* CurrentTime is just ZERO, so it's worthless for
691 determining relative click times. */
692 struct device *d = get_device_from_display (XtDisplay (daddy));
693 btn->time = DEVICE_X_MOUSE_TIMESTAMP (d); /* event-Xt maintains this */
695 XQueryPointer (btn->display, btn->window, &btn->root,
696 &btn->subwindow, &btn->x_root, &btn->y_root,
697 &btn->x, &btn->y, &btn->state);
704 x_update_frame_menubar_internal (struct frame *f)
706 /* We assume the menubar contents has changed if the global flag is set,
707 or if the current buffer has changed, or if the menubar has never
710 int menubar_contents_changed =
712 || NILP (FRAME_MENUBAR_DATA (f))
713 || (!EQ (XFRAME_MENUBAR_DATA (f)->last_menubar_buffer,
714 XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer)));
716 Boolean menubar_was_visible = XtIsManaged (FRAME_X_MENUBAR_WIDGET (f));
717 Boolean menubar_will_be_visible = menubar_was_visible;
718 Boolean menubar_visibility_changed;
720 if (menubar_contents_changed)
721 menubar_will_be_visible = set_frame_menubar (f, 0, 0);
723 menubar_visibility_changed = menubar_was_visible != menubar_will_be_visible;
725 if (!menubar_visibility_changed)
728 /* Set menubar visibility */
729 (menubar_will_be_visible ? XtManageChild : XtUnmanageChild)
730 (FRAME_X_MENUBAR_WIDGET (f));
732 MARK_FRAME_SIZE_SLIPPED (f);
736 x_update_frame_menubars (struct frame *f)
738 assert (FRAME_X_P (f));
740 x_update_frame_menubar_internal (f);
742 /* #### This isn't going to work right now that this function works on
743 a per-frame, not per-device basis. Guess what? I don't care. */
747 x_free_frame_menubars (struct frame *f)
749 Widget menubar_widget;
751 assert (FRAME_X_P (f));
753 menubar_widget = FRAME_X_MENUBAR_WIDGET (f);
756 LWLIB_ID id = XFRAME_MENUBAR_DATA (f)->id;
757 lw_destroy_all_widgets (id);
758 XFRAME_MENUBAR_DATA (f)->id = 0;
763 x_popup_menu (Lisp_Object menu_desc, Lisp_Object event)
766 struct frame *f = selected_frame ();
770 struct Lisp_Event *eev = NULL;
774 XSETFRAME (frame, f);
775 CHECK_X_FRAME (frame);
776 parent = FRAME_X_SHELL_WIDGET (f);
780 CHECK_LIVE_EVENT (event);
782 if (eev->event_type != button_press_event
783 && eev->event_type != button_release_event)
784 wrong_type_argument (Qmouse_event_p, event);
786 else if (!NILP (Vthis_command_keys))
788 /* if an event wasn't passed, use the last event of the event sequence
789 currently being executed, if that event is a mouse event */
790 eev = XEVENT (Vthis_command_keys); /* last event first */
791 if (eev->event_type != button_press_event
792 && eev->event_type != button_release_event)
795 make_dummy_xbutton_event (&xev, parent, eev);
797 if (SYMBOLP (menu_desc))
798 menu_desc = Fsymbol_value (menu_desc);
799 CHECK_CONS (menu_desc);
800 CHECK_STRING (XCAR (menu_desc));
801 data = menu_item_descriptor_to_widget_value (menu_desc, POPUP_TYPE, 1, 1);
803 if (! data) error ("no menu");
805 menu_id = new_lwlib_id ();
806 menu = lw_create_widget ("popup", "popup" /* data->name */, menu_id, data,
808 popup_menu_selection_callback,
809 popup_menu_down_callback);
810 free_popup_widget_value_tree (data);
812 gcpro_popup_callbacks (menu_id);
814 /* Setting zmacs-region-stays is necessary here because executing a command
815 from a menu is really a two-command process: the first command (bound to
816 the button-click) simply pops up the menu, and returns. This causes a
817 sequence of magic-events (destined for the popup-menu widget) to begin.
818 Eventually, a menu item is selected, and a menu-event blip is pushed onto
819 the end of the input stream, which is then executed by the event loop.
821 So there are two command-events, with a bunch of magic-events between
822 them. We don't want the *first* command event to alter the state of the
823 region, so that the region can be available as an argument for the second
827 zmacs_region_stays = 1;
830 lw_popup_menu (menu, &xev);
831 /* this speeds up display of pop-up menus */
832 XFlush (XtDisplay (parent));
837 syms_of_menubar_x (void)
842 console_type_create_menubar_x (void)
844 CONSOLE_HAS_METHOD (x, update_frame_menubars);
845 CONSOLE_HAS_METHOD (x, free_frame_menubars);
846 CONSOLE_HAS_METHOD (x, popup_menu);
850 vars_of_menubar_x (void)
852 last_popup_menu_selection_callback_id = (LWLIB_ID) -1;
854 #if defined (LWLIB_MENUBARS_LUCID)
855 Fprovide (intern ("lucid-menubars"));
856 #elif defined (LWLIB_MENUBARS_MOTIF)
857 Fprovide (intern ("motif-menubars"));
858 #elif defined (LWLIB_MENUBARS_ATHENA)
859 Fprovide (intern ("athena-menubars"));