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 */
41 Lisp_Object Qmenu_no_selection_hook;
44 /* we need a unique id for each popup menu, dialog box, and scrollbar */
45 static unsigned int lwlib_id_tick;
50 return ++lwlib_id_tick;
54 xmalloc_widget_value (void)
56 widget_value *tmp = malloc_widget_value ();
57 if (!tmp) memory_full ();
64 struct mark_widget_value_closure
66 void (*markobj) (Lisp_Object);
70 mark_widget_value_mapper (widget_value *val, void *closure)
74 struct mark_widget_value_closure *cl =
75 (struct mark_widget_value_closure *) closure;
78 VOID_TO_LISP (markee, val->call_data);
79 (cl->markobj) (markee);
84 VOID_TO_LISP (markee, val->accel);
85 (cl->markobj) (markee);
91 mark_popup_data (Lisp_Object obj, void (*markobj) (Lisp_Object))
93 struct popup_data *data = (struct popup_data *) XPOPUP_DATA (obj);
95 /* Now mark the callbacks and such that are hidden in the lwlib
100 struct mark_widget_value_closure closure;
102 closure.markobj = markobj;
103 lw_map_widget_values (data->id, mark_widget_value_mapper, &closure);
106 return data->last_menubar_buffer;
109 DEFINE_LRECORD_IMPLEMENTATION ("popup-data", popup_data,
110 mark_popup_data, internal_object_printer,
111 0, 0, 0, struct popup_data);
113 /* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
114 (id . popup-data) for GCPRO'ing the callbacks of the popup menus
116 static Lisp_Object Vpopup_callbacks;
119 gcpro_popup_callbacks (LWLIB_ID id)
121 struct popup_data *pdata;
122 Lisp_Object lid = make_int (id);
125 assert (NILP (assq_no_quit (lid, Vpopup_callbacks)));
126 pdata = alloc_lcrecord_type (struct popup_data, lrecord_popup_data);
128 pdata->last_menubar_buffer = Qnil;
129 pdata->menubar_contents_up_to_date = 0;
130 XSETPOPUP_DATA (lpdata, pdata);
131 Vpopup_callbacks = Fcons (Fcons (lid, lpdata), Vpopup_callbacks);
135 ungcpro_popup_callbacks (LWLIB_ID id)
137 Lisp_Object lid = make_int (id);
138 Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks);
139 assert (!NILP (this));
140 Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks);
144 popup_handled_p (LWLIB_ID id)
146 return NILP (assq_no_quit (make_int (id), Vpopup_callbacks));
149 /* menu_item_descriptor_to_widget_value() et al. mallocs a
150 widget_value, but then may signal lisp errors. If an error does
151 not occur, the opaque ptr we have here has had its pointer set to 0
152 to tell us not to do anything. Otherwise we free the widget value.
153 (This has nothing to do with GC, it's just about not dropping
154 pointers to malloc'd data when errors happen.) */
157 widget_value_unwind (Lisp_Object closure)
159 widget_value *wv = (widget_value *) get_opaque_ptr (closure);
160 free_opaque_ptr (closure);
162 free_widget_value (wv);
168 print_widget_value (widget_value *wv, int depth)
170 /* !!#### This function has not been Mule-ized */
173 for (i = 0; i < depth; i++) d[i] = ' ';
175 /* #### - print type field */
176 printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)"));
177 if (wv->value) printf ("%svalue: %s\n", d, wv->value);
178 if (wv->key) printf ("%skey: %s\n", d, wv->key);
179 printf ("%senabled: %d\n", d, wv->enabled);
182 printf ("\n%scontents: \n", d);
183 print_widget_value (wv->contents, depth + 5);
188 print_widget_value (wv->next, depth);
193 /* This recursively calls free_widget_value() on the tree of widgets.
194 It must free all data that was malloc'ed for these widget_values.
196 It used to be that emacs only allocated new storage for the `key' slot.
197 All other slots are pointers into the data of Lisp_Strings, and must be
200 free_popup_widget_value_tree (widget_value *wv)
203 if (wv->key) xfree (wv->key);
204 if (wv->value) xfree (wv->value);
206 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
208 if (wv->contents && (wv->contents != (widget_value*)1))
210 free_popup_widget_value_tree (wv->contents);
211 wv->contents = (widget_value *) 0xDEADBEEF;
215 free_popup_widget_value_tree (wv->next);
216 wv->next = (widget_value *) 0xDEADBEEF;
218 free_widget_value (wv);
221 /* The following is actually called from somewhere within XtDispatchEvent(),
222 called from XtAppProcessEvent() in event-Xt.c */
225 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
226 XtPointer client_data)
231 struct device *d = get_device_from_display (XtDisplay (widget));
232 struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
234 /* set in lwlib to the time stamp associated with the most recent menu
236 extern Time x_focus_timestamp_really_sucks_fix_me_better;
240 if (((EMACS_INT) client_data) == 0)
242 VOID_TO_LISP (data, client_data);
243 XSETFRAME (frame, f);
246 /* #### What the hell? I can't understand why this call is here,
247 and doing it is really courting disaster in the new event
248 model, since popup_selection_callback is called from
249 within next_event_internal() and Faccept_process_output()
250 itself calls next_event_internal(). --Ben */
252 /* Flush the X and process input */
253 Faccept_process_output (Qnil, Qnil, Qnil);
256 if (((EMACS_INT) client_data) == -1)
259 arg = Qmenu_no_selection_hook;
262 get_gui_callback (data, &fn, &arg);
264 /* This is the timestamp used for asserting focus so we need to get an
265 up-to-date value event if no events has been dispatched to emacs
267 #if defined(HAVE_MENUBARS)
268 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
270 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
272 signal_special_Xt_user_event (frame, fn, arg);
276 /* Eval the activep slot of the menu item */
277 # define wv_set_evalable_slot(slot,form) \
278 do { Lisp_Object _f_ = (form); \
279 slot = (NILP (_f_) ? 0 : \
281 !NILP (Feval (_f_))); \
284 /* Treat the activep slot of the menu item as a boolean */
285 # define wv_set_evalable_slot(slot,form) \
286 slot = (!NILP ((form)))
290 menu_separator_style (CONST char *s)
295 if (!s || s[0] == '\0')
298 if (first != '-' && first != '=')
300 for (p = s; *p == first; p++);
302 /* #### - cannot currently specify a separator tag "--!tag" and a
303 separator style "--:style" at the same time. */
304 /* #### - Also, the motif menubar code doesn't deal with the
305 double etched style yet, so it's not good to get into the habit of
306 using "===" in menubars to get double-etched lines */
307 if (*p == '!' || *p == '\0')
308 return ((first == '-')
309 ? NULL /* single etched is the default */
310 : xstrdup ("shadowDoubleEtchedIn"));
312 return xstrdup (p+1);
317 /* set menu accelerator key to first underlined character in menu name */
320 menu_name_to_accelerator (char *name)
327 if (*name=='_'&&*(name+1))
328 return make_char (tolower(*(name+1)));
335 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
339 button_item_to_widget_value (Lisp_Object desc, widget_value *wv,
340 int allow_text_field_p, int no_keys_p)
342 /* !!#### This function has not been Mule-ized */
343 /* This function cannot GC because gc_currently_forbidden is set when
345 Lisp_Object name = Qnil;
346 Lisp_Object callback = Qnil;
347 Lisp_Object suffix = Qnil;
348 Lisp_Object active_p = Qt;
349 Lisp_Object include_p = Qt;
350 Lisp_Object selected_p = Qnil;
351 Lisp_Object keys = Qnil;
352 Lisp_Object style = Qnil;
353 Lisp_Object config_tag = Qnil;
354 Lisp_Object accel = Qnil;
355 int length = XVECTOR_LENGTH (desc);
356 Lisp_Object *contents = XVECTOR_DATA (desc);
358 int selected_spec = 0, included_spec = 0;
361 signal_simple_error ("button descriptors must be at least 2 long", desc);
363 /* length 2: [ "name" callback ]
364 length 3: [ "name" callback active-p ]
365 length 4: [ "name" callback active-p suffix ]
366 or [ "name" callback keyword value ]
367 length 5+: [ "name" callback [ keyword value ]+ ]
369 plist_p = (length >= 5 || (length > 2 && KEYWORDP (contents [2])));
371 if (!plist_p && length > 2)
375 callback = contents [1];
376 active_p = contents [2];
378 suffix = contents [3];
385 signal_simple_error (
386 "button descriptor has an odd number of keywords and values",
390 callback = contents [1];
391 for (i = 2; i < length;)
393 Lisp_Object key = contents [i++];
394 Lisp_Object val = contents [i++];
396 signal_simple_error_2 ("not a keyword", key, desc);
398 if (EQ (key, Q_active)) active_p = val;
399 else if (EQ (key, Q_suffix)) suffix = val;
400 else if (EQ (key, Q_keys)) keys = val;
401 else if (EQ (key, Q_style)) style = val;
402 else if (EQ (key, Q_selected)) selected_p = val, selected_spec = 1;
403 else if (EQ (key, Q_included)) include_p = val, included_spec = 1;
404 else if (EQ (key, Q_config)) config_tag = val;
405 else if (EQ (key, Q_accelerator))
411 signal_simple_error ("bad keyboard accelerator", val);
413 else if (EQ (key, Q_filter))
414 signal_simple_error(":filter keyword not permitted on leaf nodes", desc);
416 signal_simple_error_2 ("unknown menu item keyword", key, desc);
421 if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration)))
422 || (included_spec && NILP (Feval (include_p))))
424 /* the include specification says to ignore this item. */
427 #endif /* HAVE_MENUBARS */
430 wv->name = (char *) XSTRING_DATA (name);
433 accel = menu_name_to_accelerator (wv->name);
434 wv->accel = LISP_TO_VOID (accel);
438 CONST char *const_bogosity;
441 /* Shortcut to avoid evaluating suffix each time */
442 if (STRINGP (suffix))
446 suffix2 = Feval (suffix);
447 CHECK_STRING (suffix2);
450 GET_C_STRING_FILENAME_DATA_ALLOCA (suffix2, const_bogosity);
451 wv->value = (char *) const_bogosity;
452 wv->value = xstrdup (wv->value);
455 wv_set_evalable_slot (wv->enabled, active_p);
456 wv_set_evalable_slot (wv->selected, selected_p);
458 wv->call_data = LISP_TO_VOID (callback);
462 || !menubar_show_keybindings
466 else if (!NILP (keys)) /* Use this string to generate key bindings */
469 keys = Fsubstitute_command_keys (keys);
470 if (XSTRING_LENGTH (keys) > 0)
471 wv->key = xstrdup ((char *) XSTRING_DATA (keys));
475 else if (SYMBOLP (callback)) /* Show the binding of this command. */
478 /* #### Warning, dependency here on current_buffer and point */
479 where_is_to_char (callback, buf);
481 wv->key = xstrdup (buf);
486 CHECK_SYMBOL (style);
489 /* If the callback is nil, treat this item like unselectable text.
490 This way, dashes will show up as a separator. */
492 wv->type = BUTTON_TYPE;
493 if (separator_string_p (wv->name))
495 wv->type = SEPARATOR_TYPE;
496 wv->value = menu_separator_style (wv->name);
501 /* #### - this is generally desirable for menubars, but it breaks
502 a package that uses dialog boxes and next_command_event magic
503 to use the callback slot in dialog buttons for data instead of
506 Code is data, right? The beauty of LISP abuse. --Stig */
508 wv->type = TEXT_TYPE;
511 wv->type = BUTTON_TYPE;
514 else if (EQ (style, Qbutton))
515 wv->type = BUTTON_TYPE;
516 else if (EQ (style, Qtoggle))
517 wv->type = TOGGLE_TYPE;
518 else if (EQ (style, Qradio))
519 wv->type = RADIO_TYPE;
520 else if (EQ (style, Qtext))
522 wv->type = TEXT_TYPE;
524 wv->value = wv->name;
529 signal_simple_error_2 ("unknown style", style, desc);
531 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
532 signal_simple_error ("text field not allowed in this context", desc);
534 if (selected_spec && EQ (style, Qtext))
535 signal_simple_error (
536 ":selected only makes sense with :style toggle, radio or button",
541 #endif /* HAVE_POPUPS */
543 /* This is a kludge to make sure emacs can only link against a version of
544 lwlib that was compiled in the right way. Emacs references symbols which
545 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
546 compiled in that way, then somewhat meaningful link errors will result.
547 The alternatives to this range from obscure link errors, to obscure
548 runtime errors that look a lot like bugs.
552 sanity_check_lwlib (void)
554 #define MACROLET(v) { extern int v; v = 1; }
556 #if (XlibSpecificationRelease == 4)
557 MACROLET (lwlib_uses_x11r4);
558 #elif (XlibSpecificationRelease == 5)
559 MACROLET (lwlib_uses_x11r5);
560 #elif (XlibSpecificationRelease == 6)
561 MACROLET (lwlib_uses_x11r6);
563 MACROLET (lwlib_uses_unknown_x11);
565 #ifdef LWLIB_USES_MOTIF
566 MACROLET (lwlib_uses_motif);
568 MACROLET (lwlib_does_not_use_motif);
570 #if (XmVersion >= 1002)
571 MACROLET (lwlib_uses_motif_1_2);
573 MACROLET (lwlib_does_not_use_motif_1_2);
575 #ifdef LWLIB_MENUBARS_LUCID
576 MACROLET (lwlib_menubars_lucid);
577 #elif defined (HAVE_MENUBARS)
578 MACROLET (lwlib_menubars_motif);
580 #ifdef LWLIB_SCROLLBARS_LUCID
581 MACROLET (lwlib_scrollbars_lucid);
582 #elif defined (LWLIB_SCROLLBARS_MOTIF)
583 MACROLET (lwlib_scrollbars_motif);
584 #elif defined (HAVE_SCROLLBARS)
585 MACROLET (lwlib_scrollbars_athena);
587 #ifdef LWLIB_DIALOGS_MOTIF
588 MACROLET (lwlib_dialogs_motif);
589 #elif defined (HAVE_DIALOGS)
590 MACROLET (lwlib_dialogs_athena);
600 defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
607 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
612 Vpopup_callbacks = Qnil;
613 staticpro (&Vpopup_callbacks);
616 /* This DEFVAR_LISP is just for the benefit of make-docfile. */
618 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
619 Function or functions to call when a menu or dialog box is dismissed
620 without a selection having been made.
623 Fset (Qmenu_no_selection_hook, Qnil);
624 #endif /* HAVE_POPUPS */
626 /* this makes only safe calls as in emacs.c */
627 sanity_check_lwlib ();