1 /* General GUI code -- X-specific. (menubars, scrollbars, toolbars, dialogs)
2 Copyright (C) 1995 Board of Trustees, University of Illinois.
3 Copyright (C) 1995, 1996, 2000 Ben Wing.
4 Copyright (C) 1995 Sun Microsystems, Inc.
5 Copyright (C) 1998 Free Software Foundation, Inc.
7 This file is part of SXEmacs
9 SXEmacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 SXEmacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 /* Synched up with: Not in FSF. */
25 /* This file Mule-ized by Ben Wing, 7-8-00. */
30 #include "console-x.h"
31 #ifdef LWLIB_USES_MOTIF
32 #include <Xm/Xm.h> /* for XmVersion */
33 #endif /* LWLIB_USES_MOTIF */
36 #include "ui/device.h"
37 #define INCLUDE_EVENTS_H_PRIVATE_SPHERE
38 #include "events/events.h"
41 #include "ui/glyphs.h"
42 #include "ui/redisplay.h"
45 /* we need a unique id for each popup menu, dialog box, and scrollbar */
46 static unsigned int lwlib_id_tick;
48 LWLIB_ID new_lwlib_id(void)
50 return ++lwlib_id_tick;
53 widget_value *xmalloc_widget_value(void)
55 widget_value *tmp = malloc_widget_value();
61 static int mark_widget_value_mapper(widget_value * val, void *closure)
65 VOID_TO_LISP(markee, val->call_data);
70 VOID_TO_LISP(markee, val->accel);
76 static Lisp_Object mark_popup_data(Lisp_Object obj)
78 struct popup_data *data = (struct popup_data *)XPOPUP_DATA(obj);
80 /* Now mark the callbacks and such that are hidden in the lwlib
84 lw_map_widget_values(data->id, mark_widget_value_mapper, 0);
86 return data->last_menubar_buffer;
89 DEFINE_LRECORD_IMPLEMENTATION("popup-data", popup_data,
90 mark_popup_data, internal_object_printer,
91 0, 0, 0, 0, struct popup_data);
93 /* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
94 (id . popup-data) for GCPRO'ing the callbacks of the popup menus
96 static Lisp_Object Vpopup_callbacks;
98 void gcpro_popup_callbacks(LWLIB_ID id)
100 struct popup_data *pdata;
101 Lisp_Object lid = make_int(id);
104 assert(NILP(assq_no_quit(lid, Vpopup_callbacks)));
105 pdata = alloc_lcrecord_type(struct popup_data, &lrecord_popup_data);
107 pdata->last_menubar_buffer = Qnil;
108 pdata->menubar_contents_up_to_date = 0;
109 XSETPOPUP_DATA(lpdata, pdata);
110 Vpopup_callbacks = Fcons(Fcons(lid, lpdata), Vpopup_callbacks);
113 void ungcpro_popup_callbacks(LWLIB_ID id)
115 Lisp_Object lid = make_int(id);
116 Lisp_Object this = assq_no_quit(lid, Vpopup_callbacks);
118 Vpopup_callbacks = delq_no_quit(this, Vpopup_callbacks);
121 int popup_handled_p(LWLIB_ID id)
123 return NILP(assq_no_quit(make_int(id), Vpopup_callbacks));
126 /* menu_item_descriptor_to_widget_value() et al. mallocs a
127 widget_value, but then may signal lisp errors. If an error does
128 not occur, the opaque ptr we have here has had its pointer set to 0
129 to tell us not to do anything. Otherwise we free the widget value.
130 (This has nothing to do with GC, it's just about not dropping
131 pointers to malloc'd data when errors happen.) */
133 Lisp_Object widget_value_unwind(Lisp_Object closure)
135 widget_value *wv = (widget_value *) get_opaque_ptr(closure);
136 free_opaque_ptr(closure);
138 free_widget_value_tree(wv);
143 static void print_widget_value(widget_value * wv, int depth)
145 /* strings in wv are in external format; use printf not stdout_out
146 because the latter takes internal-format strings */
149 for (i = 0; i < depth; i++)
152 /* #### - print type field */
153 printf("%sname: %s\n", d, (wv->name ? wv->name : "(null)"));
155 printf("%svalue: %s\n", d, wv->value);
157 printf("%skey: %s\n", d, wv->key);
158 printf("%senabled: %d\n", d, wv->enabled);
160 printf("\n%scontents: \n", d);
161 print_widget_value(wv->contents, depth + 5);
165 print_widget_value(wv->next, depth);
170 /* This recursively calls free_widget_value() on the tree of widgets.
171 It must free all data that was malloc'ed for these widget_values.
173 It used to be that emacs only allocated new storage for the `key' slot.
174 All other slots are pointers into the data of Lisp_Strings, and must be
176 void free_popup_widget_value_tree(widget_value * wv)
182 /* we mustnt free this? */
183 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
188 /* we mustnt free this? */
189 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
194 /* we mustnt free this? */
195 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
200 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
201 wv->name = wv->value = wv->key = NULL;
203 wv->name = wv->value = wv->key = (char *)0xDEADBEEF;
206 if (wv->contents && (wv->contents != (widget_value *) 1)) {
207 free_popup_widget_value_tree(wv->contents);
208 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
211 wv->contents = (widget_value *) 0xDEADBEEF;
215 free_popup_widget_value_tree(wv->next);
216 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
219 wv->next = (widget_value *) 0xDEADBEEF;
222 free_widget_value(wv);
226 /* The following is actually called from somewhere within XtDispatchEvent(),
227 called from XtAppProcessEvent() in event-Xt.c
229 Callback function for widgets and menus.
233 popup_selection_callback(Widget widget, LWLIB_ID ignored_id,
234 XtPointer client_data)
236 Lisp_Object data, image_instance, callback, callback_ex;
237 Lisp_Object frame, event;
238 int update_subwindows_p = 0;
239 struct device *d = get_device_from_display(XtDisplay(widget));
240 struct frame *f = x_any_widget_or_parent_to_frame(d, widget);
242 /* set in lwlib to the time stamp associated with the most recent menu
244 extern Time x_focus_timestamp_really_sucks_fix_me_better;
248 if (((EMACS_INT) client_data) == 0)
250 VOID_TO_LISP(data, client_data);
254 /* #### What the hell? I can't understand why this call is here,
255 and doing it is really courting disaster in the new event
256 model, since popup_selection_callback is called from
257 within next_event_internal() and Faccept_process_output()
258 itself calls next_event_internal(). --Ben */
260 /* Flush the X and process input */
261 Faccept_process_output(Qnil, Qnil, Qnil);
264 if (((EMACS_INT) client_data) == -1) {
265 event = Fmake_event(Qnil, Qnil);
267 XEVENT(event)->event_type = misc_user_event;
268 XEVENT(event)->channel = frame;
269 XEVENT(event)->event.eval.function = Qrun_hooks;
270 XEVENT(event)->event.eval.object = Qmenu_no_selection_hook;
272 image_instance = XCAR(data);
273 callback = XCAR(XCDR(data));
274 callback_ex = XCDR(XCDR(data));
275 update_subwindows_p = 1;
276 /* It is possible for a widget action to cause it to get out of
277 sync with its instantiator. Thus it is necessary to signal
279 if (IMAGE_INSTANCEP(image_instance))
280 XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED(image_instance) =
283 if (!NILP(callback_ex) && !UNBOUNDP(callback_ex)) {
284 event = Fmake_event(Qnil, Qnil);
286 XEVENT(event)->event_type = misc_user_event;
287 XEVENT(event)->channel = frame;
288 XEVENT(event)->event.eval.function = Qeval;
289 XEVENT(event)->event.eval.object =
290 list4(Qfuncall, callback_ex, image_instance, event);
291 } else if (NILP(callback) || UNBOUNDP(callback))
296 event = Fmake_event(Qnil, Qnil);
298 get_gui_callback(callback, &fn, &arg);
299 XEVENT(event)->event_type = misc_user_event;
300 XEVENT(event)->channel = frame;
301 XEVENT(event)->event.eval.function = fn;
302 XEVENT(event)->event.eval.object = arg;
306 /* This is the timestamp used for asserting focus so we need to get an
307 up-to-date value event if no events have been dispatched to emacs
309 #if defined(HAVE_MENUBARS)
310 DEVICE_X_MOUSE_TIMESTAMP(d) =
311 x_focus_timestamp_really_sucks_fix_me_better;
313 DEVICE_X_MOUSE_TIMESTAMP(d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP(d);
316 enqueue_Xt_dispatch_event(event);
317 /* The result of this evaluation could cause other instances to change so
318 enqueue an update callback to check this. */
319 if (update_subwindows_p && !NILP(event))
320 enqueue_magic_eval_event(update_widget_instances, frame);
324 /* Eval the activep slot of the menu item */
325 # define wv_set_evalable_slot(slot,form) do { \
326 Lisp_Object wses_form = (form); \
327 (slot) = (NILP (wses_form) ? 0 : \
328 EQ (wses_form, Qt) ? 1 : \
329 !NILP (Feval (wses_form))); \
332 /* Treat the activep slot of the menu item as a boolean */
333 # define wv_set_evalable_slot(slot,form) \
334 ((void) (slot = (!NILP (form))))
337 Extbyte *menu_separator_style_and_to_external(const Bufbyte * s)
342 if (!s || s[0] == '\0')
345 if (first != '-' && first != '=')
347 for (p = s; *p == first; p++)
350 /* #### - cannot currently specify a separator tag "--!tag" and a
351 separator style "--:style" at the same time. */
352 /* #### - Also, the motif menubar code doesn't deal with the
353 double etched style yet, so it's not good to get into the habit of
354 using "===" in menubars to get double-etched lines */
355 if (*p == '!' || *p == '\0')
356 return ((first == '-')
357 ? NULL /* single etched is the default */
358 : xstrdup("shadowDoubleEtchedIn"));
359 else if (*p == ':') {
362 C_STRING_TO_EXTERNAL_MALLOC(p + 1, retval, Qlwlib_encoding);
369 Extbyte *add_accel_and_to_external(Lisp_Object string)
374 Bufbyte *name = XSTRING_DATA(string);
376 for (i = 0; name[i]; ++i)
377 if (name[i] == '%' && name[i + 1] == '_') {
383 LISP_STRING_TO_EXTERNAL_MALLOC(string, retval, Qlwlib_encoding);
385 size_t namelen = XSTRING_LENGTH(string);
386 Bufbyte *chars = (Bufbyte *) alloca(namelen + 3);
389 memcpy(chars + 2, name, namelen + 1);
390 C_STRING_TO_EXTERNAL_MALLOC(chars, retval, Qlwlib_encoding);
396 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
399 button_item_to_widget_value(Lisp_Object gui_object_instance,
400 Lisp_Object gui_item, widget_value * wv,
401 int allow_text_field_p, int no_keys_p,
402 int menu_entry_p, int accel_p)
404 /* This function cannot GC because gc_currently_forbidden is set when
406 Lisp_Gui_Item *pgui = 0;
408 /* degenerate case */
409 if (STRINGP(gui_item)) {
410 wv->type = TEXT_TYPE;
412 wv->name = add_accel_and_to_external(gui_item);
414 LISP_STRING_TO_EXTERNAL_MALLOC(gui_item, wv->name,
417 } else if (!GUI_ITEMP(gui_item))
418 syntax_error("need a string or a gui_item here", gui_item);
420 pgui = XGUI_ITEM(gui_item);
422 if (!NILP(pgui->filter))
423 syntax_error(":filter keyword not permitted on leaf nodes",
428 && !gui_item_included_p(gui_item, Vmenubar_configuration)) {
429 /* the include specification says to ignore this item. */
432 #endif /* HAVE_MENUBARS */
434 if (!STRINGP(pgui->name))
435 pgui->name = Feval(pgui->name);
437 CHECK_STRING(pgui->name);
439 Lisp_Object tmp = gui_item_accelerator(gui_item);
440 wv->name = add_accel_and_to_external(pgui->name);
441 wv->accel = LISP_TO_VOID(tmp);
443 LISP_STRING_TO_EXTERNAL_MALLOC(pgui->name, wv->name,
445 wv->accel = LISP_TO_VOID(Qnil);
448 if (!NILP(pgui->suffix)) {
451 /* Shortcut to avoid evaluating suffix each time */
452 if (STRINGP(pgui->suffix))
453 suffix2 = pgui->suffix;
455 suffix2 = Feval(pgui->suffix);
456 CHECK_STRING(suffix2);
459 LISP_STRING_TO_EXTERNAL_MALLOC(suffix2, wv->value,
463 wv_set_evalable_slot(wv->enabled, pgui->active);
464 wv_set_evalable_slot(wv->selected, pgui->selected);
466 if (!NILP(pgui->callback) || !NILP(pgui->callback_ex)) {
467 Lisp_Object tmp = cons3(gui_object_instance,
468 pgui->callback, pgui->callback_ex);
469 wv->call_data = LISP_TO_VOID(tmp);
474 || (menu_entry_p && !menubar_show_keybindings)
478 } else if (!NILP(pgui->keys)) {
479 /* Use this string to generate key bindings */
480 CHECK_STRING(pgui->keys);
481 pgui->keys = Fsubstitute_command_keys(pgui->keys);
482 if (XSTRING_LENGTH(pgui->keys) > 0)
483 LISP_STRING_TO_EXTERNAL_MALLOC(pgui->keys, wv->key,
487 } else if (SYMBOLP(pgui->callback)) { /* Show the binding of this command. */
488 char buf[1024]; /* #### */
489 /* #### Warning, dependency here on current_buffer and point */
490 where_is_to_char(pgui->callback, buf);
492 C_STRING_TO_EXTERNAL_MALLOC(buf, wv->key,
498 CHECK_SYMBOL(pgui->style);
499 if (NILP(pgui->style)) {
500 Bufbyte *intname = NULL;
503 /* If the callback is nil, treat this item like unselectable text.
504 This way, dashes will show up as a separator. */
506 wv->type = BUTTON_TYPE;
507 TO_INTERNAL_FORMAT(C_STRING, wv->name,
508 ALLOCA, (intname, intlen), Qlwlib_encoding);
510 SXE_SET_UNUSED(intlen);
512 if (intname != NULL && separator_string_p(intname)) {
513 wv->type = SEPARATOR_TYPE;
515 menu_separator_style_and_to_external(intname);
518 /* #### - this is generally desirable for menubars, but it breaks
519 a package that uses dialog boxes and next_command_event magic
520 to use the callback slot in dialog buttons for data instead of
523 Code is data, right? The beauty of LISP abuse. --Stig */
525 wv->type = TEXT_TYPE;
528 wv->type = BUTTON_TYPE;
530 } else if (EQ(pgui->style, Qbutton))
531 wv->type = BUTTON_TYPE;
532 else if (EQ(pgui->style, Qtoggle))
533 wv->type = TOGGLE_TYPE;
534 else if (EQ(pgui->style, Qradio))
535 wv->type = RADIO_TYPE;
536 else if (EQ(pgui->style, Qtext)) {
537 wv->type = TEXT_TYPE;
539 wv->value = wv->name;
543 syntax_error_2("Unknown style", pgui->style, gui_item);
545 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
546 syntax_error("Text field not allowed in this context",
549 if (!NILP(pgui->selected) && EQ(pgui->style, Qtext))
551 (":selected only makes sense with :style toggle, radio or button",
556 /* parse tree's of gui items into widget_value hierarchies */
557 static void gui_item_children_to_widget_values(Lisp_Object
560 widget_value * parent,
563 static widget_value *gui_items_to_widget_values_1(Lisp_Object
566 widget_value * parent,
570 widget_value *wv = 0;
572 assert((parent || prev) && !(parent && prev));
573 /* now walk the tree creating widget_values as appropriate */
575 wv = xmalloc_widget_value();
577 parent->contents = wv;
580 if (!button_item_to_widget_value(gui_object_instance,
581 items, wv, 0, 1, 0, accel_p)) {
582 free_widget_value_tree(wv);
584 parent->contents = 0;
588 wv->value = xstrdup(wv->name); /* what a mess... */
590 /* first one is the parent */
591 if (CONSP(XCAR(items)))
592 syntax_error("parent item must not be a list",
596 wv = gui_items_to_widget_values_1(gui_object_instance,
600 wv = gui_items_to_widget_values_1(gui_object_instance,
601 XCAR(items), 0, prev,
603 /* the rest are the children */
604 gui_item_children_to_widget_values(gui_object_instance,
605 XCDR(items), wv, accel_p);
611 gui_item_children_to_widget_values(Lisp_Object gui_object_instance,
612 Lisp_Object items, widget_value * parent,
615 widget_value *wv = 0, *prev = 0;
619 /* first one is master */
620 prev = gui_items_to_widget_values_1(gui_object_instance, XCAR(items),
622 /* the rest are the children */
623 LIST_LOOP(rest, XCDR(items)) {
624 Lisp_Object tab = XCAR(rest);
625 wv = gui_items_to_widget_values_1(gui_object_instance, tab, 0,
631 widget_value *gui_items_to_widget_values(Lisp_Object gui_object_instance,
632 Lisp_Object items, int accel_p)
634 /* This function can GC */
635 widget_value *control = 0, *tmp = 0;
636 int count = specpdl_depth();
637 Lisp_Object wv_closure;
640 syntax_error("must have some items", items);
642 /* Inhibit GC during this conversion. The reasons for this are
643 the same as in menu_item_descriptor_to_widget_value(); see
644 the large comment above that function. */
645 record_unwind_protect(restore_gc_inhibit,
646 make_int(gc_currently_forbidden));
647 gc_currently_forbidden = 1;
649 /* Also make sure that we free the partially-created widget_value
650 tree on Lisp error. */
651 control = xmalloc_widget_value();
652 wv_closure = make_opaque_ptr(control);
653 record_unwind_protect(widget_value_unwind, wv_closure);
655 gui_items_to_widget_values_1(gui_object_instance, items, control, 0,
658 /* mess about getting the data we really want */
660 control = control->contents;
663 free_widget_value_tree(tmp);
665 /* No more need to free the half-filled-in structures. */
666 set_opaque_ptr(wv_closure, 0);
667 unbind_to(count, Qnil);
672 /* This is a kludge to make sure emacs can only link against a version of
673 lwlib that was compiled in the right way. Emacs references symbols which
674 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
675 compiled in that way, then somewhat meaningful link errors will result.
676 The alternatives to this range from obscure link errors, to obscure
677 runtime errors that look a lot like bugs.
680 static void sanity_check_lwlib(void)
682 #define MACROLET(v) { extern int v; v = 1; }
684 #if (XlibSpecificationRelease == 4)
685 MACROLET(lwlib_uses_x11r4);
686 #elif (XlibSpecificationRelease == 5)
687 MACROLET(lwlib_uses_x11r5);
688 #elif (XlibSpecificationRelease == 6)
689 MACROLET(lwlib_uses_x11r6);
691 MACROLET(lwlib_uses_unknown_x11);
693 #ifdef LWLIB_USES_MOTIF
694 MACROLET(lwlib_uses_motif);
695 #if (XmVersion >= 1002)
696 MACROLET(lwlib_uses_motif_1_2);
698 MACROLET(lwlib_does_not_use_motif_1_2);
701 MACROLET(lwlib_does_not_use_motif);
702 #endif /* LWLIB_USES_MOTIF */
703 #ifdef LWLIB_MENUBARS_LUCID
704 MACROLET(lwlib_menubars_lucid);
705 #elif defined (HAVE_MENUBARS)
706 MACROLET(lwlib_menubars_motif);
708 #ifdef LWLIB_SCROLLBARS_LUCID
709 MACROLET(lwlib_scrollbars_lucid);
710 #elif defined (LWLIB_SCROLLBARS_MOTIF)
711 MACROLET(lwlib_scrollbars_motif);
712 #elif defined (HAVE_SCROLLBARS)
713 MACROLET(lwlib_scrollbars_athena);
715 #ifdef LWLIB_DIALOGS_MOTIF
716 MACROLET(lwlib_dialogs_motif);
717 #elif defined (HAVE_DIALOGS)
718 MACROLET(lwlib_dialogs_athena);
720 #ifdef LWLIB_WIDGETS_MOTIF
721 MACROLET(lwlib_widgets_motif);
722 #elif defined (HAVE_WIDGETS)
723 MACROLET(lwlib_widgets_athena);
729 void syms_of_gui_x(void)
731 INIT_LRECORD_IMPLEMENTATION(popup_data);
734 void reinit_vars_of_gui_x(void)
736 lwlib_id_tick = (1 << 16); /* start big, to not conflict with Energize */
741 /* this makes only safe calls as in emacs.c */
742 sanity_check_lwlib();
745 void vars_of_gui_x(void)
747 reinit_vars_of_gui_x();
749 Vpopup_callbacks = Qnil;
750 staticpro(&Vpopup_callbacks);