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 */
40 #include "redisplay.h"
43 Lisp_Object Qmenu_no_selection_hook;
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 /* !!#### This function has not been Mule-ized */
159 for (i = 0; i < depth; i++) d[i] = ' ';
161 /* #### - print type field */
162 printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)"));
163 if (wv->value) printf ("%svalue: %s\n", d, wv->value);
164 if (wv->key) printf ("%skey: %s\n", d, wv->key);
165 printf ("%senabled: %d\n", d, wv->enabled);
168 printf ("\n%scontents: \n", d);
169 print_widget_value (wv->contents, depth + 5);
174 print_widget_value (wv->next, depth);
179 /* This recursively calls free_widget_value() on the tree of widgets.
180 It must free all data that was malloc'ed for these widget_values.
182 It used to be that emacs only allocated new storage for the `key' slot.
183 All other slots are pointers into the data of Lisp_Strings, and must be
186 free_popup_widget_value_tree (widget_value *wv)
189 if (wv->key) xfree (wv->key);
190 if (wv->value) xfree (wv->value);
191 if (wv->name) xfree (wv->name);
193 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
195 if (wv->contents && (wv->contents != (widget_value*)1))
197 free_popup_widget_value_tree (wv->contents);
198 wv->contents = (widget_value *) 0xDEADBEEF;
202 free_popup_widget_value_tree (wv->next);
203 wv->next = (widget_value *) 0xDEADBEEF;
205 free_widget_value (wv);
208 /* The following is actually called from somewhere within XtDispatchEvent(),
209 called from XtAppProcessEvent() in event-Xt.c */
212 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
213 XtPointer client_data)
215 Lisp_Object data, image_instance, callback, callback_ex;
216 Lisp_Object frame, event;
217 int update_subwindows_p = 0;
218 struct device *d = get_device_from_display (XtDisplay (widget));
219 struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
221 /* set in lwlib to the time stamp associated with the most recent menu
223 extern Time x_focus_timestamp_really_sucks_fix_me_better;
227 if (((EMACS_INT) client_data) == 0)
229 VOID_TO_LISP (data, client_data);
230 XSETFRAME (frame, f);
232 image_instance = XCAR (data);
233 callback = XCAR (XCDR (data));
234 callback_ex = XCDR (XCDR (data));
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 update_subwindows_p = 1;
260 if (!NILP (callback_ex) && !UNBOUNDP (callback_ex))
262 event = Fmake_event (Qnil, Qnil);
264 XEVENT (event)->event_type = misc_user_event;
265 XEVENT (event)->channel = frame;
266 XEVENT (event)->event.eval.function = Qeval;
267 XEVENT (event)->event.eval.object =
268 list4 (Qfuncall, callback_ex, image_instance, event);
270 else if (NILP (callback) || UNBOUNDP (callback))
276 event = Fmake_event (Qnil, Qnil);
278 get_gui_callback (callback, &fn, &arg);
279 XEVENT (event)->event_type = misc_user_event;
280 XEVENT (event)->channel = frame;
281 XEVENT (event)->event.eval.function = fn;
282 XEVENT (event)->event.eval.object = arg;
286 /* This is the timestamp used for asserting focus so we need to get an
287 up-to-date value event if no events has been dispatched to emacs
289 #if defined(HAVE_MENUBARS)
290 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
292 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
295 enqueue_Xt_dispatch_event (event);
296 /* The result of this evaluation could cause other instances to change so
297 enqueue an update callback to check this. We also have to make sure that
298 the function does not appear in the command history.
299 #### I'm sure someone can tell me how to optimize this. */
300 if (update_subwindows_p && !NILP (event))
301 signal_special_Xt_user_event (frame, Qeval,
303 list2 (Qthis_command,
305 list2 (Qupdate_widget_instances,
310 /* Eval the activep slot of the menu item */
311 # define wv_set_evalable_slot(slot,form) do { \
312 Lisp_Object wses_form = (form); \
313 (slot) = (NILP (wses_form) ? 0 : \
314 EQ (wses_form, Qt) ? 1 : \
315 !NILP (Feval (wses_form))); \
318 /* Treat the activep slot of the menu item as a boolean */
319 # define wv_set_evalable_slot(slot,form) \
320 ((void) (slot = (!NILP (form))))
324 menu_separator_style (const char *s)
329 if (!s || s[0] == '\0')
332 if (first != '-' && first != '=')
334 for (p = s; *p == first; p++)
337 /* #### - cannot currently specify a separator tag "--!tag" and a
338 separator style "--:style" at the same time. */
339 /* #### - Also, the motif menubar code doesn't deal with the
340 double etched style yet, so it's not good to get into the habit of
341 using "===" in menubars to get double-etched lines */
342 if (*p == '!' || *p == '\0')
343 return ((first == '-')
344 ? NULL /* single etched is the default */
345 : xstrdup ("shadowDoubleEtchedIn"));
347 return xstrdup (p+1);
353 strdup_and_add_accel (char *name)
358 for (i=0; name[i]; ++i)
359 if (name[i] == '%' && name[i+1] == '_')
366 return xstrdup (name);
369 char *chars = (char *) alloca (strlen (name) + 3);
372 memcpy (chars+2, name, strlen (name) + 1);
373 return xstrdup (chars);
377 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
380 button_item_to_widget_value (Lisp_Object gui_object_instance,
381 Lisp_Object gui_item, widget_value *wv,
382 int allow_text_field_p, int no_keys_p,
385 /* !!#### This function has not been Mule-ized */
386 /* This function cannot GC because gc_currently_forbidden is set when
388 Lisp_Gui_Item* pgui = 0;
390 /* degenerate case */
391 if (STRINGP (gui_item))
393 wv->type = TEXT_TYPE;
394 wv->name = (char *) XSTRING_DATA (gui_item);
395 wv->name = strdup_and_add_accel (wv->name);
398 else if (!GUI_ITEMP (gui_item))
399 signal_simple_error("need a string or a gui_item here", gui_item);
401 pgui = XGUI_ITEM (gui_item);
403 if (!NILP (pgui->filter))
404 signal_simple_error(":filter keyword not permitted on leaf nodes", gui_item);
407 if (menu_entry_p && !gui_item_included_p (gui_item, Vmenubar_configuration))
409 /* the include specification says to ignore this item. */
412 #endif /* HAVE_MENUBARS */
414 if (!STRINGP (pgui->name))
415 pgui->name = Feval (pgui->name);
417 CHECK_STRING (pgui->name);
418 wv->name = (char *) XSTRING_DATA (pgui->name);
419 wv->name = xstrdup (wv->name);
420 wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
422 if (!NILP (pgui->suffix))
424 const char *const_bogosity;
427 /* Shortcut to avoid evaluating suffix each time */
428 if (STRINGP (pgui->suffix))
429 suffix2 = pgui->suffix;
432 suffix2 = Feval (pgui->suffix);
433 CHECK_STRING (suffix2);
436 TO_EXTERNAL_FORMAT (LISP_STRING, suffix2,
437 C_STRING_ALLOCA, const_bogosity,
439 wv->value = (char *) const_bogosity;
440 wv->value = xstrdup (wv->value);
443 wv_set_evalable_slot (wv->enabled, pgui->active);
444 wv_set_evalable_slot (wv->selected, pgui->selected);
446 if (!NILP (pgui->callback) || !NILP (pgui->callback_ex))
447 wv->call_data = LISP_TO_VOID (cons3 (gui_object_instance,
453 || (menu_entry_p && !menubar_show_keybindings)
457 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */
459 CHECK_STRING (pgui->keys);
460 pgui->keys = Fsubstitute_command_keys (pgui->keys);
461 if (XSTRING_LENGTH (pgui->keys) > 0)
462 wv->key = xstrdup ((char *) XSTRING_DATA (pgui->keys));
466 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */
468 char buf[1024]; /* #### */
469 /* #### Warning, dependency here on current_buffer and point */
470 where_is_to_char (pgui->callback, buf);
472 wv->key = xstrdup (buf);
477 CHECK_SYMBOL (pgui->style);
478 if (NILP (pgui->style))
480 /* If the callback is nil, treat this item like unselectable text.
481 This way, dashes will show up as a separator. */
483 wv->type = BUTTON_TYPE;
484 if (separator_string_p (wv->name))
486 wv->type = SEPARATOR_TYPE;
487 wv->value = menu_separator_style (wv->name);
492 /* #### - this is generally desirable for menubars, but it breaks
493 a package that uses dialog boxes and next_command_event magic
494 to use the callback slot in dialog buttons for data instead of
497 Code is data, right? The beauty of LISP abuse. --Stig */
499 wv->type = TEXT_TYPE;
502 wv->type = BUTTON_TYPE;
505 else if (EQ (pgui->style, Qbutton))
506 wv->type = BUTTON_TYPE;
507 else if (EQ (pgui->style, Qtoggle))
508 wv->type = TOGGLE_TYPE;
509 else if (EQ (pgui->style, Qradio))
510 wv->type = RADIO_TYPE;
511 else if (EQ (pgui->style, Qtext))
513 wv->type = TEXT_TYPE;
515 wv->value = wv->name;
520 signal_simple_error_2 ("Unknown style", pgui->style, gui_item);
522 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
523 signal_simple_error ("Text field not allowed in this context", gui_item);
525 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
526 signal_simple_error (
527 ":selected only makes sense with :style toggle, radio or button",
532 /* parse tree's of gui items into widget_value hierarchies */
533 static void gui_item_children_to_widget_values (Lisp_Object gui_object_instance,
535 widget_value* parent);
537 static widget_value *
538 gui_items_to_widget_values_1 (Lisp_Object gui_object_instance,
539 Lisp_Object items, widget_value* parent,
542 widget_value* wv = 0;
544 assert ((parent || prev) && !(parent && prev));
545 /* now walk the tree creating widget_values as appropriate */
548 wv = xmalloc_widget_value();
550 parent->contents = wv;
553 if (!button_item_to_widget_value (gui_object_instance,
556 free_widget_value_tree (wv);
558 parent->contents = 0;
564 wv->value = xstrdup (wv->name); /* what a mess... */
569 /* first one is the parent */
570 if (CONSP (XCAR (items)))
571 signal_simple_error ("parent item must not be a list", XCAR (items));
574 wv = gui_items_to_widget_values_1 (gui_object_instance,
575 XCAR (items), parent, 0);
577 wv = gui_items_to_widget_values_1 (gui_object_instance,
578 XCAR (items), 0, prev);
579 /* the rest are the children */
580 gui_item_children_to_widget_values (gui_object_instance,
587 gui_item_children_to_widget_values (Lisp_Object gui_object_instance,
588 Lisp_Object items, widget_value* parent)
590 widget_value* wv = 0, *prev = 0;
594 /* first one is master */
595 prev = gui_items_to_widget_values_1 (gui_object_instance, XCAR (items),
597 /* the rest are the children */
598 LIST_LOOP (rest, XCDR (items))
600 Lisp_Object tab = XCAR (rest);
601 wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev);
607 gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items)
609 /* !!#### This function has not been Mule-ized */
610 /* This function can GC */
611 widget_value *control = 0, *tmp = 0;
612 int count = specpdl_depth ();
613 Lisp_Object wv_closure;
616 signal_simple_error ("must have some items", items);
618 /* Inhibit GC during this conversion. The reasons for this are
619 the same as in menu_item_descriptor_to_widget_value(); see
620 the large comment above that function. */
621 record_unwind_protect (restore_gc_inhibit,
622 make_int (gc_currently_forbidden));
623 gc_currently_forbidden = 1;
625 /* Also make sure that we free the partially-created widget_value
626 tree on Lisp error. */
627 control = xmalloc_widget_value();
628 wv_closure = make_opaque_ptr (control);
629 record_unwind_protect (widget_value_unwind, wv_closure);
631 gui_items_to_widget_values_1 (gui_object_instance, items, control, 0);
633 /* mess about getting the data we really want */
635 control = control->contents;
638 free_widget_value_tree (tmp);
640 /* No more need to free the half-filled-in structures. */
641 set_opaque_ptr (wv_closure, 0);
642 unbind_to (count, Qnil);
647 /* This is a kludge to make sure emacs can only link against a version of
648 lwlib that was compiled in the right way. Emacs references symbols which
649 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
650 compiled in that way, then somewhat meaningful link errors will result.
651 The alternatives to this range from obscure link errors, to obscure
652 runtime errors that look a lot like bugs.
656 sanity_check_lwlib (void)
658 #define MACROLET(v) { extern int v; v = 1; }
660 #if (XlibSpecificationRelease == 4)
661 MACROLET (lwlib_uses_x11r4);
662 #elif (XlibSpecificationRelease == 5)
663 MACROLET (lwlib_uses_x11r5);
664 #elif (XlibSpecificationRelease == 6)
665 MACROLET (lwlib_uses_x11r6);
667 MACROLET (lwlib_uses_unknown_x11);
669 #ifdef LWLIB_USES_MOTIF
670 MACROLET (lwlib_uses_motif);
672 MACROLET (lwlib_does_not_use_motif);
674 #if (XmVersion >= 1002)
675 MACROLET (lwlib_uses_motif_1_2);
677 MACROLET (lwlib_does_not_use_motif_1_2);
679 #ifdef LWLIB_MENUBARS_LUCID
680 MACROLET (lwlib_menubars_lucid);
681 #elif defined (HAVE_MENUBARS)
682 MACROLET (lwlib_menubars_motif);
684 #ifdef LWLIB_SCROLLBARS_LUCID
685 MACROLET (lwlib_scrollbars_lucid);
686 #elif defined (LWLIB_SCROLLBARS_MOTIF)
687 MACROLET (lwlib_scrollbars_motif);
688 #elif defined (HAVE_SCROLLBARS)
689 MACROLET (lwlib_scrollbars_athena);
691 #ifdef LWLIB_DIALOGS_MOTIF
692 MACROLET (lwlib_dialogs_motif);
693 #elif defined (HAVE_DIALOGS)
694 MACROLET (lwlib_dialogs_athena);
696 #ifdef LWLIB_WIDGETS_MOTIF
697 MACROLET (lwlib_widgets_motif);
698 #elif defined (HAVE_WIDGETS)
699 MACROLET (lwlib_widgets_athena);
708 INIT_LRECORD_IMPLEMENTATION (popup_data);
710 defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
714 reinit_vars_of_gui_x (void)
716 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
721 /* this makes only safe calls as in emacs.c */
722 sanity_check_lwlib ();
728 reinit_vars_of_gui_x ();
730 Vpopup_callbacks = Qnil;
731 staticpro (&Vpopup_callbacks);
734 /* This DEFVAR_LISP is just for the benefit of make-docfile. */
736 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
737 Function or functions to call when a menu or dialog box is dismissed
738 without a selection having been made.
741 Fset (Qmenu_no_selection_hook, Qnil);