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 XEmacs.
9 XEmacs is free software; you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by the
11 Free Software Foundation; either version 2, or (at your option) any
14 XEmacs is distributed in the hope that it will be useful, but WITHOUT
15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with XEmacs; see the file COPYING. If not, write to
21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 Boston, MA 02111-1307, USA. */
24 /* Synched up with: Not in FSF. */
26 /* This file Mule-ized by Ben Wing, 7-8-00. */
31 #include "console-x.h"
32 #ifdef LWLIB_USES_MOTIF
33 #include <Xm/Xm.h> /* for XmVersion */
42 #include "redisplay.h"
45 /* we need a unique id for each popup menu, dialog box, and scrollbar */
46 static unsigned int lwlib_id_tick;
51 return ++lwlib_id_tick;
55 xmalloc_widget_value (void)
57 widget_value *tmp = malloc_widget_value ();
58 if (!tmp) memory_full ();
64 mark_widget_value_mapper (widget_value *val, void *closure)
69 VOID_TO_LISP (markee, val->call_data);
75 VOID_TO_LISP (markee, val->accel);
82 mark_popup_data (Lisp_Object obj)
84 struct popup_data *data = (struct popup_data *) XPOPUP_DATA (obj);
86 /* Now mark the callbacks and such that are hidden in the lwlib
90 lw_map_widget_values (data->id, mark_widget_value_mapper, 0);
92 return data->last_menubar_buffer;
95 DEFINE_LRECORD_IMPLEMENTATION ("popup-data", popup_data,
96 mark_popup_data, internal_object_printer,
97 0, 0, 0, 0, struct popup_data);
99 /* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
100 (id . popup-data) for GCPRO'ing the callbacks of the popup menus
102 static Lisp_Object Vpopup_callbacks;
105 gcpro_popup_callbacks (LWLIB_ID id)
107 struct popup_data *pdata;
108 Lisp_Object lid = make_int (id);
111 assert (NILP (assq_no_quit (lid, Vpopup_callbacks)));
112 pdata = alloc_lcrecord_type (struct popup_data, &lrecord_popup_data);
114 pdata->last_menubar_buffer = Qnil;
115 pdata->menubar_contents_up_to_date = 0;
116 XSETPOPUP_DATA (lpdata, pdata);
117 Vpopup_callbacks = Fcons (Fcons (lid, lpdata), Vpopup_callbacks);
121 ungcpro_popup_callbacks (LWLIB_ID id)
123 Lisp_Object lid = make_int (id);
124 Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks);
125 assert (!NILP (this));
126 Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks);
130 popup_handled_p (LWLIB_ID id)
132 return NILP (assq_no_quit (make_int (id), Vpopup_callbacks));
135 /* menu_item_descriptor_to_widget_value() et al. mallocs a
136 widget_value, but then may signal lisp errors. If an error does
137 not occur, the opaque ptr we have here has had its pointer set to 0
138 to tell us not to do anything. Otherwise we free the widget value.
139 (This has nothing to do with GC, it's just about not dropping
140 pointers to malloc'd data when errors happen.) */
143 widget_value_unwind (Lisp_Object closure)
145 widget_value *wv = (widget_value *) get_opaque_ptr (closure);
146 free_opaque_ptr (closure);
148 free_widget_value_tree (wv);
154 print_widget_value (widget_value *wv, int depth)
156 /* strings in wv are in external format; use printf not stdout_out
157 because the latter takes internal-format strings */
160 for (i = 0; i < depth; i++) d[i] = ' ';
162 /* #### - print type field */
163 printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)"));
164 if (wv->value) printf ("%svalue: %s\n", d, wv->value);
165 if (wv->key) printf ("%skey: %s\n", d, wv->key);
166 printf ("%senabled: %d\n", d, wv->enabled);
169 printf ("\n%scontents: \n", d);
170 print_widget_value (wv->contents, depth + 5);
175 print_widget_value (wv->next, depth);
180 /* This recursively calls free_widget_value() on the tree of widgets.
181 It must free all data that was malloc'ed for these widget_values.
183 It used to be that emacs only allocated new storage for the `key' slot.
184 All other slots are pointers into the data of Lisp_Strings, and must be
187 free_popup_widget_value_tree (widget_value *wv)
190 if (wv->key) xfree (wv->key);
191 if (wv->value) xfree (wv->value);
192 if (wv->name) xfree (wv->name);
194 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
196 if (wv->contents && (wv->contents != (widget_value*)1))
198 free_popup_widget_value_tree (wv->contents);
199 wv->contents = (widget_value *) 0xDEADBEEF;
203 free_popup_widget_value_tree (wv->next);
204 wv->next = (widget_value *) 0xDEADBEEF;
206 free_widget_value (wv);
209 /* The following is actually called from somewhere within XtDispatchEvent(),
210 called from XtAppProcessEvent() in event-Xt.c
212 Callback function for widgets and menus.
216 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
217 XtPointer client_data)
219 Lisp_Object data, image_instance, callback, callback_ex;
220 Lisp_Object frame, event;
221 int update_subwindows_p = 0;
222 struct device *d = get_device_from_display (XtDisplay (widget));
223 struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
225 /* set in lwlib to the time stamp associated with the most recent menu
227 extern Time x_focus_timestamp_really_sucks_fix_me_better;
231 if (((EMACS_INT) client_data) == 0)
233 VOID_TO_LISP (data, client_data);
234 XSETFRAME (frame, f);
237 /* #### What the hell? I can't understand why this call is here,
238 and doing it is really courting disaster in the new event
239 model, since popup_selection_callback is called from
240 within next_event_internal() and Faccept_process_output()
241 itself calls next_event_internal(). --Ben */
243 /* Flush the X and process input */
244 Faccept_process_output (Qnil, Qnil, Qnil);
247 if (((EMACS_INT) client_data) == -1)
249 event = Fmake_event (Qnil, Qnil);
251 XEVENT (event)->event_type = misc_user_event;
252 XEVENT (event)->channel = frame;
253 XEVENT (event)->event.eval.function = Qrun_hooks;
254 XEVENT (event)->event.eval.object = Qmenu_no_selection_hook;
258 image_instance = XCAR (data);
259 callback = XCAR (XCDR (data));
260 callback_ex = XCDR (XCDR (data));
261 update_subwindows_p = 1;
262 /* It is possible for a widget action to cause it to get out of
263 sync with its instantiator. Thus it is necessary to signal
265 if (IMAGE_INSTANCEP (image_instance))
266 XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (image_instance) = 1;
268 if (!NILP (callback_ex) && !UNBOUNDP (callback_ex))
270 event = Fmake_event (Qnil, Qnil);
272 XEVENT (event)->event_type = misc_user_event;
273 XEVENT (event)->channel = frame;
274 XEVENT (event)->event.eval.function = Qeval;
275 XEVENT (event)->event.eval.object =
276 list4 (Qfuncall, callback_ex, image_instance, event);
278 else if (NILP (callback) || UNBOUNDP (callback))
284 event = Fmake_event (Qnil, Qnil);
286 get_gui_callback (callback, &fn, &arg);
287 XEVENT (event)->event_type = misc_user_event;
288 XEVENT (event)->channel = frame;
289 XEVENT (event)->event.eval.function = fn;
290 XEVENT (event)->event.eval.object = arg;
294 /* This is the timestamp used for asserting focus so we need to get an
295 up-to-date value event if no events have been dispatched to emacs
297 #if defined(HAVE_MENUBARS)
298 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
300 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
303 enqueue_Xt_dispatch_event (event);
304 /* The result of this evaluation could cause other instances to change so
305 enqueue an update callback to check this. */
306 if (update_subwindows_p && !NILP (event))
307 enqueue_magic_eval_event (update_widget_instances, frame);
311 /* Eval the activep slot of the menu item */
312 # define wv_set_evalable_slot(slot,form) do { \
313 Lisp_Object wses_form = (form); \
314 (slot) = (NILP (wses_form) ? 0 : \
315 EQ (wses_form, Qt) ? 1 : \
316 !NILP (Feval (wses_form))); \
319 /* Treat the activep slot of the menu item as a boolean */
320 # define wv_set_evalable_slot(slot,form) \
321 ((void) (slot = (!NILP (form))))
325 menu_separator_style_and_to_external (const Bufbyte *s)
330 if (!s || s[0] == '\0')
333 if (first != '-' && first != '=')
335 for (p = s; *p == first; p++)
338 /* #### - cannot currently specify a separator tag "--!tag" and a
339 separator style "--:style" at the same time. */
340 /* #### - Also, the motif menubar code doesn't deal with the
341 double etched style yet, so it's not good to get into the habit of
342 using "===" in menubars to get double-etched lines */
343 if (*p == '!' || *p == '\0')
344 return ((first == '-')
345 ? NULL /* single etched is the default */
346 : xstrdup ("shadowDoubleEtchedIn"));
351 C_STRING_TO_EXTERNAL_MALLOC (p + 1, retval, Qlwlib_encoding);
359 add_accel_and_to_external (Lisp_Object string)
364 Bufbyte *name = XSTRING_DATA (string);
366 for (i = 0; name[i]; ++i)
367 if (name[i] == '%' && name[i+1] == '_')
374 LISP_STRING_TO_EXTERNAL_MALLOC (string, retval, Qlwlib_encoding);
377 size_t namelen = XSTRING_LENGTH (string);
378 Bufbyte *chars = (Bufbyte *) alloca (namelen + 3);
381 memcpy (chars + 2, name, namelen + 1);
382 C_STRING_TO_EXTERNAL_MALLOC (chars, retval, Qlwlib_encoding);
388 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
391 button_item_to_widget_value (Lisp_Object gui_object_instance,
392 Lisp_Object gui_item, widget_value *wv,
393 int allow_text_field_p, int no_keys_p,
394 int menu_entry_p, int accel_p)
396 /* This function cannot GC because gc_currently_forbidden is set when
398 Lisp_Gui_Item* pgui = 0;
400 /* degenerate case */
401 if (STRINGP (gui_item))
403 wv->type = TEXT_TYPE;
405 wv->name = add_accel_and_to_external (gui_item);
407 LISP_STRING_TO_EXTERNAL_MALLOC (gui_item, wv->name, Qlwlib_encoding);
410 else if (!GUI_ITEMP (gui_item))
411 syntax_error ("need a string or a gui_item here", gui_item);
413 pgui = XGUI_ITEM (gui_item);
415 if (!NILP (pgui->filter))
416 syntax_error (":filter keyword not permitted on leaf nodes", gui_item);
419 if (menu_entry_p && !gui_item_included_p (gui_item, Vmenubar_configuration))
421 /* the include specification says to ignore this item. */
424 #endif /* HAVE_MENUBARS */
426 if (!STRINGP (pgui->name))
427 pgui->name = Feval (pgui->name);
429 CHECK_STRING (pgui->name);
432 wv->name = add_accel_and_to_external (pgui->name);
433 wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
437 LISP_STRING_TO_EXTERNAL_MALLOC (pgui->name, wv->name, Qlwlib_encoding);
438 wv->accel = LISP_TO_VOID (Qnil);
441 if (!NILP (pgui->suffix))
445 /* Shortcut to avoid evaluating suffix each time */
446 if (STRINGP (pgui->suffix))
447 suffix2 = pgui->suffix;
450 suffix2 = Feval (pgui->suffix);
451 CHECK_STRING (suffix2);
454 LISP_STRING_TO_EXTERNAL_MALLOC (suffix2, wv->value, Qlwlib_encoding);
457 wv_set_evalable_slot (wv->enabled, pgui->active);
458 wv_set_evalable_slot (wv->selected, pgui->selected);
460 if (!NILP (pgui->callback) || !NILP (pgui->callback_ex))
461 wv->call_data = LISP_TO_VOID (cons3 (gui_object_instance,
467 || (menu_entry_p && !menubar_show_keybindings)
471 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */
473 CHECK_STRING (pgui->keys);
474 pgui->keys = Fsubstitute_command_keys (pgui->keys);
475 if (XSTRING_LENGTH (pgui->keys) > 0)
476 LISP_STRING_TO_EXTERNAL_MALLOC (pgui->keys, wv->key, Qlwlib_encoding);
480 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */
482 char buf[1024]; /* #### */
483 /* #### Warning, dependency here on current_buffer and point */
484 where_is_to_char (pgui->callback, buf);
486 C_STRING_TO_EXTERNAL_MALLOC (buf, wv->key, Qlwlib_encoding);
491 CHECK_SYMBOL (pgui->style);
492 if (NILP (pgui->style))
496 /* If the callback is nil, treat this item like unselectable text.
497 This way, dashes will show up as a separator. */
499 wv->type = BUTTON_TYPE;
500 TO_INTERNAL_FORMAT (C_STRING, wv->name,
501 ALLOCA, (intname, intlen),
503 if (separator_string_p (intname))
505 wv->type = SEPARATOR_TYPE;
506 wv->value = menu_separator_style_and_to_external (intname);
511 /* #### - this is generally desirable for menubars, but it breaks
512 a package that uses dialog boxes and next_command_event magic
513 to use the callback slot in dialog buttons for data instead of
516 Code is data, right? The beauty of LISP abuse. --Stig */
518 wv->type = TEXT_TYPE;
521 wv->type = BUTTON_TYPE;
524 else if (EQ (pgui->style, Qbutton))
525 wv->type = BUTTON_TYPE;
526 else if (EQ (pgui->style, Qtoggle))
527 wv->type = TOGGLE_TYPE;
528 else if (EQ (pgui->style, Qradio))
529 wv->type = RADIO_TYPE;
530 else if (EQ (pgui->style, Qtext))
532 wv->type = TEXT_TYPE;
534 wv->value = wv->name;
539 syntax_error_2 ("Unknown style", pgui->style, gui_item);
541 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
542 syntax_error ("Text field not allowed in this context", gui_item);
544 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
546 (":selected only makes sense with :style toggle, radio or button",
551 /* parse tree's of gui items into widget_value hierarchies */
552 static void gui_item_children_to_widget_values (Lisp_Object
555 widget_value* parent,
558 static widget_value *
559 gui_items_to_widget_values_1 (Lisp_Object gui_object_instance,
560 Lisp_Object items, widget_value* parent,
561 widget_value* prev, int accel_p)
563 widget_value* wv = 0;
565 assert ((parent || prev) && !(parent && prev));
566 /* now walk the tree creating widget_values as appropriate */
569 wv = xmalloc_widget_value ();
571 parent->contents = wv;
574 if (!button_item_to_widget_value (gui_object_instance,
575 items, wv, 0, 1, 0, accel_p))
577 free_widget_value_tree (wv);
579 parent->contents = 0;
584 wv->value = xstrdup (wv->name); /* what a mess... */
588 /* first one is the parent */
589 if (CONSP (XCAR (items)))
590 syntax_error ("parent item must not be a list", XCAR (items));
593 wv = gui_items_to_widget_values_1 (gui_object_instance,
594 XCAR (items), parent, 0, accel_p);
596 wv = gui_items_to_widget_values_1 (gui_object_instance,
597 XCAR (items), 0, prev, accel_p);
598 /* the rest are the children */
599 gui_item_children_to_widget_values (gui_object_instance,
600 XCDR (items), wv, accel_p);
606 gui_item_children_to_widget_values (Lisp_Object gui_object_instance,
607 Lisp_Object items, widget_value* parent,
610 widget_value* wv = 0, *prev = 0;
614 /* first one is master */
615 prev = gui_items_to_widget_values_1 (gui_object_instance, XCAR (items),
617 /* the rest are the children */
618 LIST_LOOP (rest, XCDR (items))
620 Lisp_Object tab = XCAR (rest);
621 wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev,
628 gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items,
631 /* This function can GC */
632 widget_value *control = 0, *tmp = 0;
633 int count = specpdl_depth ();
634 Lisp_Object wv_closure;
637 syntax_error ("must have some items", items);
639 /* Inhibit GC during this conversion. The reasons for this are
640 the same as in menu_item_descriptor_to_widget_value(); see
641 the large comment above that function. */
642 record_unwind_protect (restore_gc_inhibit,
643 make_int (gc_currently_forbidden));
644 gc_currently_forbidden = 1;
646 /* Also make sure that we free the partially-created widget_value
647 tree on Lisp error. */
648 control = xmalloc_widget_value ();
649 wv_closure = make_opaque_ptr (control);
650 record_unwind_protect (widget_value_unwind, wv_closure);
652 gui_items_to_widget_values_1 (gui_object_instance, items, control, 0,
655 /* mess about getting the data we really want */
657 control = control->contents;
660 free_widget_value_tree (tmp);
662 /* No more need to free the half-filled-in structures. */
663 set_opaque_ptr (wv_closure, 0);
664 unbind_to (count, Qnil);
669 /* This is a kludge to make sure emacs can only link against a version of
670 lwlib that was compiled in the right way. Emacs references symbols which
671 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
672 compiled in that way, then somewhat meaningful link errors will result.
673 The alternatives to this range from obscure link errors, to obscure
674 runtime errors that look a lot like bugs.
678 sanity_check_lwlib (void)
680 #define MACROLET(v) { extern int v; v = 1; }
682 #if (XlibSpecificationRelease == 4)
683 MACROLET (lwlib_uses_x11r4);
684 #elif (XlibSpecificationRelease == 5)
685 MACROLET (lwlib_uses_x11r5);
686 #elif (XlibSpecificationRelease == 6)
687 MACROLET (lwlib_uses_x11r6);
689 MACROLET (lwlib_uses_unknown_x11);
691 #ifdef LWLIB_USES_MOTIF
692 MACROLET (lwlib_uses_motif);
694 MACROLET (lwlib_does_not_use_motif);
696 #if (XmVersion >= 1002)
697 MACROLET (lwlib_uses_motif_1_2);
699 MACROLET (lwlib_does_not_use_motif_1_2);
701 #ifdef LWLIB_MENUBARS_LUCID
702 MACROLET (lwlib_menubars_lucid);
703 #elif defined (HAVE_MENUBARS)
704 MACROLET (lwlib_menubars_motif);
706 #ifdef LWLIB_SCROLLBARS_LUCID
707 MACROLET (lwlib_scrollbars_lucid);
708 #elif defined (LWLIB_SCROLLBARS_MOTIF)
709 MACROLET (lwlib_scrollbars_motif);
710 #elif defined (HAVE_SCROLLBARS)
711 MACROLET (lwlib_scrollbars_athena);
713 #ifdef LWLIB_DIALOGS_MOTIF
714 MACROLET (lwlib_dialogs_motif);
715 #elif defined (HAVE_DIALOGS)
716 MACROLET (lwlib_dialogs_athena);
718 #ifdef LWLIB_WIDGETS_MOTIF
719 MACROLET (lwlib_widgets_motif);
720 #elif defined (HAVE_WIDGETS)
721 MACROLET (lwlib_widgets_athena);
730 INIT_LRECORD_IMPLEMENTATION (popup_data);
734 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 ();
748 reinit_vars_of_gui_x ();
750 Vpopup_callbacks = Qnil;
751 staticpro (&Vpopup_callbacks);