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 */
213 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
214 XtPointer client_data)
216 Lisp_Object data, image_instance, callback, callback_ex;
217 Lisp_Object frame, event;
218 int update_subwindows_p = 0;
219 struct device *d = get_device_from_display (XtDisplay (widget));
220 struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
222 /* set in lwlib to the time stamp associated with the most recent menu
224 extern Time x_focus_timestamp_really_sucks_fix_me_better;
228 if (((EMACS_INT) client_data) == 0)
230 VOID_TO_LISP (data, client_data);
231 XSETFRAME (frame, f);
234 /* #### What the hell? I can't understand why this call is here,
235 and doing it is really courting disaster in the new event
236 model, since popup_selection_callback is called from
237 within next_event_internal() and Faccept_process_output()
238 itself calls next_event_internal(). --Ben */
240 /* Flush the X and process input */
241 Faccept_process_output (Qnil, Qnil, Qnil);
244 if (((EMACS_INT) client_data) == -1)
246 event = Fmake_event (Qnil, Qnil);
248 XEVENT (event)->event_type = misc_user_event;
249 XEVENT (event)->channel = frame;
250 XEVENT (event)->event.eval.function = Qrun_hooks;
251 XEVENT (event)->event.eval.object = Qmenu_no_selection_hook;
255 image_instance = XCAR (data);
256 callback = XCAR (XCDR (data));
257 callback_ex = XCDR (XCDR (data));
258 update_subwindows_p = 1;
259 /* It is possible for a widget action to cause it to get out of
260 sync with its instantiator. Thus it is necessary to signal
262 if (IMAGE_INSTANCEP (image_instance))
263 XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (image_instance) = 1;
265 if (!NILP (callback_ex) && !UNBOUNDP (callback_ex))
267 event = Fmake_event (Qnil, Qnil);
269 XEVENT (event)->event_type = misc_user_event;
270 XEVENT (event)->channel = frame;
271 XEVENT (event)->event.eval.function = Qeval;
272 XEVENT (event)->event.eval.object =
273 list4 (Qfuncall, callback_ex, image_instance, event);
275 else if (NILP (callback) || UNBOUNDP (callback))
281 event = Fmake_event (Qnil, Qnil);
283 get_gui_callback (callback, &fn, &arg);
284 XEVENT (event)->event_type = misc_user_event;
285 XEVENT (event)->channel = frame;
286 XEVENT (event)->event.eval.function = fn;
287 XEVENT (event)->event.eval.object = arg;
291 /* This is the timestamp used for asserting focus so we need to get an
292 up-to-date value event if no events has been dispatched to emacs
294 #if defined(HAVE_MENUBARS)
295 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
297 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
300 enqueue_Xt_dispatch_event (event);
301 /* The result of this evaluation could cause other instances to change so
302 enqueue an update callback to check this. */
303 if (update_subwindows_p && !NILP (event))
304 enqueue_magic_eval_event (update_widget_instances, frame);
308 /* Eval the activep slot of the menu item */
309 # define wv_set_evalable_slot(slot,form) do { \
310 Lisp_Object wses_form = (form); \
311 (slot) = (NILP (wses_form) ? 0 : \
312 EQ (wses_form, Qt) ? 1 : \
313 !NILP (Feval (wses_form))); \
316 /* Treat the activep slot of the menu item as a boolean */
317 # define wv_set_evalable_slot(slot,form) \
318 ((void) (slot = (!NILP (form))))
322 menu_separator_style_and_to_external (const Bufbyte *s)
327 if (!s || s[0] == '\0')
330 if (first != '-' && first != '=')
332 for (p = s; *p == first; p++)
335 /* #### - cannot currently specify a separator tag "--!tag" and a
336 separator style "--:style" at the same time. */
337 /* #### - Also, the motif menubar code doesn't deal with the
338 double etched style yet, so it's not good to get into the habit of
339 using "===" in menubars to get double-etched lines */
340 if (*p == '!' || *p == '\0')
341 return ((first == '-')
342 ? NULL /* single etched is the default */
343 : xstrdup ("shadowDoubleEtchedIn"));
348 C_STRING_TO_EXTERNAL_MALLOC (p + 1, retval, Qlwlib_encoding);
356 add_accel_and_to_external (Lisp_Object string)
361 Bufbyte *name = XSTRING_DATA (string);
363 for (i = 0; name[i]; ++i)
364 if (name[i] == '%' && name[i+1] == '_')
371 LISP_STRING_TO_EXTERNAL_MALLOC (string, retval, Qlwlib_encoding);
374 size_t namelen = XSTRING_LENGTH (string);
375 Bufbyte *chars = (Bufbyte *) alloca (namelen + 3);
378 memcpy (chars + 2, name, namelen + 1);
379 C_STRING_TO_EXTERNAL_MALLOC (chars, retval, Qlwlib_encoding);
385 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
388 button_item_to_widget_value (Lisp_Object gui_object_instance,
389 Lisp_Object gui_item, widget_value *wv,
390 int allow_text_field_p, int no_keys_p,
391 int menu_entry_p, int accel_p)
393 /* This function cannot GC because gc_currently_forbidden is set when
395 Lisp_Gui_Item* pgui = 0;
397 /* degenerate case */
398 if (STRINGP (gui_item))
400 wv->type = TEXT_TYPE;
402 wv->name = add_accel_and_to_external (gui_item);
404 LISP_STRING_TO_EXTERNAL_MALLOC (gui_item, wv->name, Qlwlib_encoding);
407 else if (!GUI_ITEMP (gui_item))
408 syntax_error ("need a string or a gui_item here", gui_item);
410 pgui = XGUI_ITEM (gui_item);
412 if (!NILP (pgui->filter))
413 syntax_error (":filter keyword not permitted on leaf nodes", gui_item);
416 if (menu_entry_p && !gui_item_included_p (gui_item, Vmenubar_configuration))
418 /* the include specification says to ignore this item. */
421 #endif /* HAVE_MENUBARS */
423 if (!STRINGP (pgui->name))
424 pgui->name = Feval (pgui->name);
426 CHECK_STRING (pgui->name);
429 wv->name = add_accel_and_to_external (pgui->name);
430 wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
434 LISP_STRING_TO_EXTERNAL_MALLOC (pgui->name, wv->name, Qlwlib_encoding);
435 wv->accel = LISP_TO_VOID (Qnil);
438 if (!NILP (pgui->suffix))
442 /* Shortcut to avoid evaluating suffix each time */
443 if (STRINGP (pgui->suffix))
444 suffix2 = pgui->suffix;
447 suffix2 = Feval (pgui->suffix);
448 CHECK_STRING (suffix2);
451 LISP_STRING_TO_EXTERNAL_MALLOC (suffix2, wv->value, Qlwlib_encoding);
454 wv_set_evalable_slot (wv->enabled, pgui->active);
455 wv_set_evalable_slot (wv->selected, pgui->selected);
457 if (!NILP (pgui->callback) || !NILP (pgui->callback_ex))
458 wv->call_data = LISP_TO_VOID (cons3 (gui_object_instance,
464 || (menu_entry_p && !menubar_show_keybindings)
468 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */
470 CHECK_STRING (pgui->keys);
471 pgui->keys = Fsubstitute_command_keys (pgui->keys);
472 if (XSTRING_LENGTH (pgui->keys) > 0)
473 LISP_STRING_TO_EXTERNAL_MALLOC (pgui->keys, wv->key, Qlwlib_encoding);
477 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */
479 char buf[1024]; /* #### */
480 /* #### Warning, dependency here on current_buffer and point */
481 where_is_to_char (pgui->callback, buf);
483 C_STRING_TO_EXTERNAL_MALLOC (buf, wv->key, Qlwlib_encoding);
488 CHECK_SYMBOL (pgui->style);
489 if (NILP (pgui->style))
492 /* If the callback is nil, treat this item like unselectable text.
493 This way, dashes will show up as a separator. */
495 wv->type = BUTTON_TYPE;
496 EXTERNAL_TO_C_STRING (wv->name, intname, Qlwlib_encoding);
497 if (separator_string_p (intname))
499 wv->type = SEPARATOR_TYPE;
500 wv->value = menu_separator_style_and_to_external (intname);
505 /* #### - this is generally desirable for menubars, but it breaks
506 a package that uses dialog boxes and next_command_event magic
507 to use the callback slot in dialog buttons for data instead of
510 Code is data, right? The beauty of LISP abuse. --Stig */
512 wv->type = TEXT_TYPE;
515 wv->type = BUTTON_TYPE;
518 else if (EQ (pgui->style, Qbutton))
519 wv->type = BUTTON_TYPE;
520 else if (EQ (pgui->style, Qtoggle))
521 wv->type = TOGGLE_TYPE;
522 else if (EQ (pgui->style, Qradio))
523 wv->type = RADIO_TYPE;
524 else if (EQ (pgui->style, Qtext))
526 wv->type = TEXT_TYPE;
528 wv->value = wv->name;
533 syntax_error_2 ("Unknown style", pgui->style, gui_item);
535 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
536 syntax_error ("Text field not allowed in this context", gui_item);
538 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
540 (":selected only makes sense with :style toggle, radio or button",
545 /* parse tree's of gui items into widget_value hierarchies */
546 static void gui_item_children_to_widget_values (Lisp_Object
549 widget_value* parent,
552 static widget_value *
553 gui_items_to_widget_values_1 (Lisp_Object gui_object_instance,
554 Lisp_Object items, widget_value* parent,
555 widget_value* prev, int accel_p)
557 widget_value* wv = 0;
559 assert ((parent || prev) && !(parent && prev));
560 /* now walk the tree creating widget_values as appropriate */
563 wv = xmalloc_widget_value ();
565 parent->contents = wv;
568 if (!button_item_to_widget_value (gui_object_instance,
569 items, wv, 0, 1, 0, accel_p))
571 free_widget_value_tree (wv);
573 parent->contents = 0;
578 wv->value = xstrdup (wv->name); /* what a mess... */
582 /* first one is the parent */
583 if (CONSP (XCAR (items)))
584 syntax_error ("parent item must not be a list", XCAR (items));
587 wv = gui_items_to_widget_values_1 (gui_object_instance,
588 XCAR (items), parent, 0, accel_p);
590 wv = gui_items_to_widget_values_1 (gui_object_instance,
591 XCAR (items), 0, prev, accel_p);
592 /* the rest are the children */
593 gui_item_children_to_widget_values (gui_object_instance,
594 XCDR (items), wv, accel_p);
600 gui_item_children_to_widget_values (Lisp_Object gui_object_instance,
601 Lisp_Object items, widget_value* parent,
604 widget_value* wv = 0, *prev = 0;
608 /* first one is master */
609 prev = gui_items_to_widget_values_1 (gui_object_instance, XCAR (items),
611 /* the rest are the children */
612 LIST_LOOP (rest, XCDR (items))
614 Lisp_Object tab = XCAR (rest);
615 wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev,
622 gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items,
625 /* This function can GC */
626 widget_value *control = 0, *tmp = 0;
627 int count = specpdl_depth ();
628 Lisp_Object wv_closure;
631 syntax_error ("must have some items", items);
633 /* Inhibit GC during this conversion. The reasons for this are
634 the same as in menu_item_descriptor_to_widget_value(); see
635 the large comment above that function. */
636 record_unwind_protect (restore_gc_inhibit,
637 make_int (gc_currently_forbidden));
638 gc_currently_forbidden = 1;
640 /* Also make sure that we free the partially-created widget_value
641 tree on Lisp error. */
642 control = xmalloc_widget_value ();
643 wv_closure = make_opaque_ptr (control);
644 record_unwind_protect (widget_value_unwind, wv_closure);
646 gui_items_to_widget_values_1 (gui_object_instance, items, control, 0,
649 /* mess about getting the data we really want */
651 control = control->contents;
654 free_widget_value_tree (tmp);
656 /* No more need to free the half-filled-in structures. */
657 set_opaque_ptr (wv_closure, 0);
658 unbind_to (count, Qnil);
663 /* This is a kludge to make sure emacs can only link against a version of
664 lwlib that was compiled in the right way. Emacs references symbols which
665 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
666 compiled in that way, then somewhat meaningful link errors will result.
667 The alternatives to this range from obscure link errors, to obscure
668 runtime errors that look a lot like bugs.
672 sanity_check_lwlib (void)
674 #define MACROLET(v) { extern int v; v = 1; }
676 #if (XlibSpecificationRelease == 4)
677 MACROLET (lwlib_uses_x11r4);
678 #elif (XlibSpecificationRelease == 5)
679 MACROLET (lwlib_uses_x11r5);
680 #elif (XlibSpecificationRelease == 6)
681 MACROLET (lwlib_uses_x11r6);
683 MACROLET (lwlib_uses_unknown_x11);
685 #ifdef LWLIB_USES_MOTIF
686 MACROLET (lwlib_uses_motif);
688 MACROLET (lwlib_does_not_use_motif);
690 #if (XmVersion >= 1002)
691 MACROLET (lwlib_uses_motif_1_2);
693 MACROLET (lwlib_does_not_use_motif_1_2);
695 #ifdef LWLIB_MENUBARS_LUCID
696 MACROLET (lwlib_menubars_lucid);
697 #elif defined (HAVE_MENUBARS)
698 MACROLET (lwlib_menubars_motif);
700 #ifdef LWLIB_SCROLLBARS_LUCID
701 MACROLET (lwlib_scrollbars_lucid);
702 #elif defined (LWLIB_SCROLLBARS_MOTIF)
703 MACROLET (lwlib_scrollbars_motif);
704 #elif defined (HAVE_SCROLLBARS)
705 MACROLET (lwlib_scrollbars_athena);
707 #ifdef LWLIB_DIALOGS_MOTIF
708 MACROLET (lwlib_dialogs_motif);
709 #elif defined (HAVE_DIALOGS)
710 MACROLET (lwlib_dialogs_athena);
712 #ifdef LWLIB_WIDGETS_MOTIF
713 MACROLET (lwlib_widgets_motif);
714 #elif defined (HAVE_WIDGETS)
715 MACROLET (lwlib_widgets_athena);
724 INIT_LRECORD_IMPLEMENTATION (popup_data);
728 reinit_vars_of_gui_x (void)
730 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
735 /* this makes only safe calls as in emacs.c */
736 sanity_check_lwlib ();
742 reinit_vars_of_gui_x ();
744 Vpopup_callbacks = Qnil;
745 staticpro (&Vpopup_callbacks);