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 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. */
29 #include "console-x.h"
30 #ifdef LWLIB_USES_MOTIF
31 #include <Xm/Xm.h> /* for XmVersion */
38 #include "redisplay.h"
41 Lisp_Object Qmenu_no_selection_hook;
43 /* we need a unique id for each popup menu, dialog box, and scrollbar */
44 static unsigned int lwlib_id_tick;
49 return ++lwlib_id_tick;
53 xmalloc_widget_value (void)
55 widget_value *tmp = malloc_widget_value ();
56 if (!tmp) memory_full ();
62 mark_widget_value_mapper (widget_value *val, void *closure)
67 VOID_TO_LISP (markee, val->call_data);
73 VOID_TO_LISP (markee, val->accel);
80 mark_popup_data (Lisp_Object obj)
82 struct popup_data *data = (struct popup_data *) XPOPUP_DATA (obj);
84 /* Now mark the callbacks and such that are hidden in the lwlib
88 lw_map_widget_values (data->id, mark_widget_value_mapper, 0);
90 return data->last_menubar_buffer;
93 DEFINE_LRECORD_IMPLEMENTATION ("popup-data", popup_data,
94 mark_popup_data, internal_object_printer,
95 0, 0, 0, 0, struct popup_data);
97 /* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
98 (id . popup-data) for GCPRO'ing the callbacks of the popup menus
100 static Lisp_Object Vpopup_callbacks;
103 gcpro_popup_callbacks (LWLIB_ID id)
105 struct popup_data *pdata;
106 Lisp_Object lid = make_int (id);
109 assert (NILP (assq_no_quit (lid, Vpopup_callbacks)));
110 pdata = alloc_lcrecord_type (struct popup_data, &lrecord_popup_data);
112 pdata->last_menubar_buffer = Qnil;
113 pdata->menubar_contents_up_to_date = 0;
114 XSETPOPUP_DATA (lpdata, pdata);
115 Vpopup_callbacks = Fcons (Fcons (lid, lpdata), Vpopup_callbacks);
119 ungcpro_popup_callbacks (LWLIB_ID id)
121 Lisp_Object lid = make_int (id);
122 Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks);
123 assert (!NILP (this));
124 Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks);
128 popup_handled_p (LWLIB_ID id)
130 return NILP (assq_no_quit (make_int (id), Vpopup_callbacks));
133 /* menu_item_descriptor_to_widget_value() et al. mallocs a
134 widget_value, but then may signal lisp errors. If an error does
135 not occur, the opaque ptr we have here has had its pointer set to 0
136 to tell us not to do anything. Otherwise we free the widget value.
137 (This has nothing to do with GC, it's just about not dropping
138 pointers to malloc'd data when errors happen.) */
141 widget_value_unwind (Lisp_Object closure)
143 widget_value *wv = (widget_value *) get_opaque_ptr (closure);
144 free_opaque_ptr (closure);
146 free_widget_value_tree (wv);
152 print_widget_value (widget_value *wv, int depth)
154 /* !!#### This function has not been Mule-ized */
157 for (i = 0; i < depth; i++) d[i] = ' ';
159 /* #### - print type field */
160 printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)"));
161 if (wv->value) printf ("%svalue: %s\n", d, wv->value);
162 if (wv->key) printf ("%skey: %s\n", d, wv->key);
163 printf ("%senabled: %d\n", d, wv->enabled);
166 printf ("\n%scontents: \n", d);
167 print_widget_value (wv->contents, depth + 5);
172 print_widget_value (wv->next, depth);
177 /* This recursively calls free_widget_value() on the tree of widgets.
178 It must free all data that was malloc'ed for these widget_values.
180 It used to be that emacs only allocated new storage for the `key' slot.
181 All other slots are pointers into the data of Lisp_Strings, and must be
184 free_popup_widget_value_tree (widget_value *wv)
187 if (wv->key) xfree (wv->key);
188 if (wv->value) xfree (wv->value);
189 if (wv->name) xfree (wv->name);
191 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
193 if (wv->contents && (wv->contents != (widget_value*)1))
195 free_popup_widget_value_tree (wv->contents);
196 wv->contents = (widget_value *) 0xDEADBEEF;
200 free_popup_widget_value_tree (wv->next);
201 wv->next = (widget_value *) 0xDEADBEEF;
203 free_widget_value (wv);
206 /* The following is actually called from somewhere within XtDispatchEvent(),
207 called from XtAppProcessEvent() in event-Xt.c */
210 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
211 XtPointer client_data)
216 int update_subwindows_p = 0;
217 struct device *d = get_device_from_display (XtDisplay (widget));
218 struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
220 /* set in lwlib to the time stamp associated with the most recent menu
222 extern Time x_focus_timestamp_really_sucks_fix_me_better;
226 if (((EMACS_INT) client_data) == 0)
228 VOID_TO_LISP (data, client_data);
229 XSETFRAME (frame, f);
232 /* #### What the hell? I can't understand why this call is here,
233 and doing it is really courting disaster in the new event
234 model, since popup_selection_callback is called from
235 within next_event_internal() and Faccept_process_output()
236 itself calls next_event_internal(). --Ben */
238 /* Flush the X and process input */
239 Faccept_process_output (Qnil, Qnil, Qnil);
242 if (((EMACS_INT) client_data) == -1)
245 arg = Qmenu_no_selection_hook;
249 update_subwindows_p = 1;
250 get_gui_callback (data, &fn, &arg);
253 /* This is the timestamp used for asserting focus so we need to get an
254 up-to-date value event if no events has been dispatched to emacs
256 #if defined(HAVE_MENUBARS)
257 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
259 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
261 signal_special_Xt_user_event (frame, fn, arg);
262 /* The result of this evaluation could cause other instances to change so
263 enqueue an update callback to check this. */
264 if (update_subwindows_p)
265 signal_special_Xt_user_event (frame, Qeval,
266 list2 (Qupdate_widget_instances, frame));
270 /* Eval the activep slot of the menu item */
271 # define wv_set_evalable_slot(slot,form) do { \
272 Lisp_Object wses_form = (form); \
273 (slot) = (NILP (wses_form) ? 0 : \
274 EQ (wses_form, Qt) ? 1 : \
275 !NILP (Feval (wses_form))); \
278 /* Treat the activep slot of the menu item as a boolean */
279 # define wv_set_evalable_slot(slot,form) \
280 ((void) (slot = (!NILP (form))))
284 menu_separator_style (const char *s)
289 if (!s || s[0] == '\0')
292 if (first != '-' && first != '=')
294 for (p = s; *p == first; p++)
297 /* #### - cannot currently specify a separator tag "--!tag" and a
298 separator style "--:style" at the same time. */
299 /* #### - Also, the motif menubar code doesn't deal with the
300 double etched style yet, so it's not good to get into the habit of
301 using "===" in menubars to get double-etched lines */
302 if (*p == '!' || *p == '\0')
303 return ((first == '-')
304 ? NULL /* single etched is the default */
305 : xstrdup ("shadowDoubleEtchedIn"));
307 return xstrdup (p+1);
313 strdup_and_add_accel (char *name)
318 for (i=0; name[i]; ++i)
319 if (name[i] == '%' && name[i+1] == '_')
326 return xstrdup (name);
329 char *chars = (char *) alloca (strlen (name) + 3);
332 memcpy (chars+2, name, strlen (name) + 1);
333 return xstrdup (chars);
337 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
340 button_item_to_widget_value (Lisp_Object gui_item, widget_value *wv,
341 int allow_text_field_p, int no_keys_p)
343 /* !!#### This function has not been Mule-ized */
344 /* This function cannot GC because gc_currently_forbidden is set when
346 Lisp_Gui_Item* pgui = 0;
348 /* degenerate case */
349 if (STRINGP (gui_item))
351 wv->type = TEXT_TYPE;
352 wv->name = (char *) XSTRING_DATA (gui_item);
353 wv->name = strdup_and_add_accel (wv->name);
356 else if (!GUI_ITEMP (gui_item))
357 signal_simple_error("need a string or a gui_item here", gui_item);
359 pgui = XGUI_ITEM (gui_item);
361 if (!NILP (pgui->filter))
362 signal_simple_error(":filter keyword not permitted on leaf nodes", gui_item);
365 if (!gui_item_included_p (gui_item, Vmenubar_configuration))
367 /* the include specification says to ignore this item. */
370 #endif /* HAVE_MENUBARS */
372 if (!STRINGP (pgui->name))
373 pgui->name = Feval (pgui->name);
375 CHECK_STRING (pgui->name);
376 wv->name = (char *) XSTRING_DATA (pgui->name);
377 wv->name = xstrdup (wv->name);
378 wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
380 if (!NILP (pgui->suffix))
382 const char *const_bogosity;
385 /* Shortcut to avoid evaluating suffix each time */
386 if (STRINGP (pgui->suffix))
387 suffix2 = pgui->suffix;
390 suffix2 = Feval (pgui->suffix);
391 CHECK_STRING (suffix2);
394 TO_EXTERNAL_FORMAT (LISP_STRING, suffix2,
395 C_STRING_ALLOCA, const_bogosity,
397 wv->value = (char *) const_bogosity;
398 wv->value = xstrdup (wv->value);
401 wv_set_evalable_slot (wv->enabled, pgui->active);
402 wv_set_evalable_slot (wv->selected, pgui->selected);
404 if (!NILP (pgui->callback))
405 wv->call_data = LISP_TO_VOID (pgui->callback);
409 || !menubar_show_keybindings
413 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */
415 CHECK_STRING (pgui->keys);
416 pgui->keys = Fsubstitute_command_keys (pgui->keys);
417 if (XSTRING_LENGTH (pgui->keys) > 0)
418 wv->key = xstrdup ((char *) XSTRING_DATA (pgui->keys));
422 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */
424 char buf[1024]; /* #### */
425 /* #### Warning, dependency here on current_buffer and point */
426 where_is_to_char (pgui->callback, buf);
428 wv->key = xstrdup (buf);
433 CHECK_SYMBOL (pgui->style);
434 if (NILP (pgui->style))
436 /* If the callback is nil, treat this item like unselectable text.
437 This way, dashes will show up as a separator. */
439 wv->type = BUTTON_TYPE;
440 if (separator_string_p (wv->name))
442 wv->type = SEPARATOR_TYPE;
443 wv->value = menu_separator_style (wv->name);
448 /* #### - this is generally desirable for menubars, but it breaks
449 a package that uses dialog boxes and next_command_event magic
450 to use the callback slot in dialog buttons for data instead of
453 Code is data, right? The beauty of LISP abuse. --Stig */
455 wv->type = TEXT_TYPE;
458 wv->type = BUTTON_TYPE;
461 else if (EQ (pgui->style, Qbutton))
462 wv->type = BUTTON_TYPE;
463 else if (EQ (pgui->style, Qtoggle))
464 wv->type = TOGGLE_TYPE;
465 else if (EQ (pgui->style, Qradio))
466 wv->type = RADIO_TYPE;
467 else if (EQ (pgui->style, Qtext))
469 wv->type = TEXT_TYPE;
471 wv->value = wv->name;
476 signal_simple_error_2 ("Unknown style", pgui->style, gui_item);
478 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
479 signal_simple_error ("Text field not allowed in this context", gui_item);
481 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
482 signal_simple_error (
483 ":selected only makes sense with :style toggle, radio or button",
488 /* parse tree's of gui items into widget_value hierarchies */
489 static void gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent);
491 static widget_value *
492 gui_items_to_widget_values_1 (Lisp_Object items, widget_value* parent,
495 widget_value* wv = 0;
497 assert ((parent || prev) && !(parent && prev));
498 /* now walk the tree creating widget_values as appropriate */
501 wv = xmalloc_widget_value();
503 parent->contents = wv;
506 if (!button_item_to_widget_value (items, wv, 0, 1))
508 free_widget_value_tree (wv);
510 parent->contents = 0;
516 wv->value = xstrdup (wv->name); /* what a mess... */
521 /* first one is the parent */
522 if (CONSP (XCAR (items)))
523 signal_simple_error ("parent item must not be a list", XCAR (items));
526 wv = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
528 wv = gui_items_to_widget_values_1 (XCAR (items), 0, prev);
529 /* the rest are the children */
530 gui_item_children_to_widget_values (XCDR (items), wv);
536 gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent)
538 widget_value* wv = 0, *prev = 0;
542 /* first one is master */
543 prev = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
544 /* the rest are the children */
545 LIST_LOOP (rest, XCDR (items))
547 Lisp_Object tab = XCAR (rest);
548 wv = gui_items_to_widget_values_1 (tab, 0, prev);
554 gui_items_to_widget_values (Lisp_Object items)
556 /* !!#### This function has not been Mule-ized */
557 /* This function can GC */
558 widget_value *control = 0, *tmp = 0;
559 int count = specpdl_depth ();
560 Lisp_Object wv_closure;
563 signal_simple_error ("must have some items", items);
565 /* Inhibit GC during this conversion. The reasons for this are
566 the same as in menu_item_descriptor_to_widget_value(); see
567 the large comment above that function. */
568 record_unwind_protect (restore_gc_inhibit,
569 make_int (gc_currently_forbidden));
570 gc_currently_forbidden = 1;
572 /* Also make sure that we free the partially-created widget_value
573 tree on Lisp error. */
574 control = xmalloc_widget_value();
575 wv_closure = make_opaque_ptr (control);
576 record_unwind_protect (widget_value_unwind, wv_closure);
578 gui_items_to_widget_values_1 (items, control, 0);
580 /* mess about getting the data we really want */
582 control = control->contents;
585 free_widget_value_tree (tmp);
587 /* No more need to free the half-filled-in structures. */
588 set_opaque_ptr (wv_closure, 0);
589 unbind_to (count, Qnil);
594 /* This is a kludge to make sure emacs can only link against a version of
595 lwlib that was compiled in the right way. Emacs references symbols which
596 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
597 compiled in that way, then somewhat meaningful link errors will result.
598 The alternatives to this range from obscure link errors, to obscure
599 runtime errors that look a lot like bugs.
603 sanity_check_lwlib (void)
605 #define MACROLET(v) { extern int v; v = 1; }
607 #if (XlibSpecificationRelease == 4)
608 MACROLET (lwlib_uses_x11r4);
609 #elif (XlibSpecificationRelease == 5)
610 MACROLET (lwlib_uses_x11r5);
611 #elif (XlibSpecificationRelease == 6)
612 MACROLET (lwlib_uses_x11r6);
614 MACROLET (lwlib_uses_unknown_x11);
616 #ifdef LWLIB_USES_MOTIF
617 MACROLET (lwlib_uses_motif);
619 MACROLET (lwlib_does_not_use_motif);
621 #if (XmVersion >= 1002)
622 MACROLET (lwlib_uses_motif_1_2);
624 MACROLET (lwlib_does_not_use_motif_1_2);
626 #ifdef LWLIB_MENUBARS_LUCID
627 MACROLET (lwlib_menubars_lucid);
628 #elif defined (HAVE_MENUBARS)
629 MACROLET (lwlib_menubars_motif);
631 #ifdef LWLIB_SCROLLBARS_LUCID
632 MACROLET (lwlib_scrollbars_lucid);
633 #elif defined (LWLIB_SCROLLBARS_MOTIF)
634 MACROLET (lwlib_scrollbars_motif);
635 #elif defined (HAVE_SCROLLBARS)
636 MACROLET (lwlib_scrollbars_athena);
638 #ifdef LWLIB_DIALOGS_MOTIF
639 MACROLET (lwlib_dialogs_motif);
640 #elif defined (HAVE_DIALOGS)
641 MACROLET (lwlib_dialogs_athena);
643 #ifdef LWLIB_WIDGETS_MOTIF
644 MACROLET (lwlib_widgets_motif);
645 #elif defined (HAVE_WIDGETS)
646 MACROLET (lwlib_widgets_athena);
655 INIT_LRECORD_IMPLEMENTATION (popup_data);
657 defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
661 reinit_vars_of_gui_x (void)
663 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
668 /* this makes only safe calls as in emacs.c */
669 sanity_check_lwlib ();
675 reinit_vars_of_gui_x ();
677 Vpopup_callbacks = Qnil;
678 staticpro (&Vpopup_callbacks);
681 /* This DEFVAR_LISP is just for the benefit of make-docfile. */
683 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
684 Function or functions to call when a menu or dialog box is dismissed
685 without a selection having been made.
688 Fset (Qmenu_no_selection_hook, Qnil);