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) do { \
278 Lisp_Object wses_form = (form); \
279 (slot) = (NILP (wses_form) ? 0 : \
280 EQ (wses_form, Qt) ? 1 : \
281 !NILP (Feval (wses_form))); \
284 /* Treat the activep slot of the menu item as a boolean */
285 # define wv_set_evalable_slot(slot,form) \
286 ((void) (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++)
303 /* #### - cannot currently specify a separator tag "--!tag" and a
304 separator style "--:style" at the same time. */
305 /* #### - Also, the motif menubar code doesn't deal with the
306 double etched style yet, so it's not good to get into the habit of
307 using "===" in menubars to get double-etched lines */
308 if (*p == '!' || *p == '\0')
309 return ((first == '-')
310 ? NULL /* single etched is the default */
311 : xstrdup ("shadowDoubleEtchedIn"));
313 return xstrdup (p+1);
318 /* set menu accelerator key to first underlined character in menu name */
321 menu_name_to_accelerator (char *name)
328 if (*name=='_' && *(name+1))
330 int accelerator = (int) (unsigned char) (*(name+1));
331 return make_char (tolower (accelerator));
339 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
343 button_item_to_widget_value (Lisp_Object desc, widget_value *wv,
344 int allow_text_field_p, int no_keys_p)
346 /* !!#### This function has not been Mule-ized */
347 /* This function cannot GC because gc_currently_forbidden is set when
349 Lisp_Object name = Qnil;
350 Lisp_Object callback = Qnil;
351 Lisp_Object suffix = Qnil;
352 Lisp_Object active_p = Qt;
353 Lisp_Object include_p = Qt;
354 Lisp_Object selected_p = Qnil;
355 Lisp_Object keys = Qnil;
356 Lisp_Object style = Qnil;
357 Lisp_Object config_tag = Qnil;
358 Lisp_Object accel = Qnil;
359 int length = XVECTOR_LENGTH (desc);
360 Lisp_Object *contents = XVECTOR_DATA (desc);
362 int selected_spec = 0, included_spec = 0;
365 signal_simple_error ("Button descriptors must be at least 2 long", desc);
367 /* length 2: [ "name" callback ]
368 length 3: [ "name" callback active-p ]
369 length 4: [ "name" callback active-p suffix ]
370 or [ "name" callback keyword value ]
371 length 5+: [ "name" callback [ keyword value ]+ ]
373 plist_p = (length >= 5 || (length > 2 && KEYWORDP (contents [2])));
375 if (!plist_p && length > 2)
379 callback = contents [1];
380 active_p = contents [2];
382 suffix = contents [3];
389 signal_simple_error (
390 "Button descriptor has an odd number of keywords and values",
394 callback = contents [1];
395 for (i = 2; i < length;)
397 Lisp_Object key = contents [i++];
398 Lisp_Object val = contents [i++];
400 signal_simple_error_2 ("Not a keyword", key, desc);
402 if (EQ (key, Q_active)) active_p = val;
403 else if (EQ (key, Q_suffix)) suffix = val;
404 else if (EQ (key, Q_keys)) keys = val;
405 else if (EQ (key, Q_style)) style = val;
406 else if (EQ (key, Q_selected)) selected_p = val, selected_spec = 1;
407 else if (EQ (key, Q_included)) include_p = val, included_spec = 1;
408 else if (EQ (key, Q_config)) config_tag = val;
409 else if (EQ (key, Q_accelerator))
415 signal_simple_error ("Bad keyboard accelerator", val);
417 else if (EQ (key, Q_filter))
418 signal_simple_error(":filter keyword not permitted on leaf nodes", desc);
420 signal_simple_error_2 ("Unknown menu item keyword", key, desc);
425 if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration)))
426 || (included_spec && NILP (Feval (include_p))))
428 /* the include specification says to ignore this item. */
431 #endif /* HAVE_MENUBARS */
434 wv->name = (char *) XSTRING_DATA (name);
437 accel = menu_name_to_accelerator (wv->name);
438 wv->accel = LISP_TO_VOID (accel);
442 CONST char *const_bogosity;
445 /* Shortcut to avoid evaluating suffix each time */
446 if (STRINGP (suffix))
450 suffix2 = Feval (suffix);
451 CHECK_STRING (suffix2);
454 GET_C_STRING_FILENAME_DATA_ALLOCA (suffix2, const_bogosity);
455 wv->value = (char *) const_bogosity;
456 wv->value = xstrdup (wv->value);
459 wv_set_evalable_slot (wv->enabled, active_p);
460 wv_set_evalable_slot (wv->selected, selected_p);
462 wv->call_data = LISP_TO_VOID (callback);
466 || !menubar_show_keybindings
470 else if (!NILP (keys)) /* Use this string to generate key bindings */
473 keys = Fsubstitute_command_keys (keys);
474 if (XSTRING_LENGTH (keys) > 0)
475 wv->key = xstrdup ((char *) XSTRING_DATA (keys));
479 else if (SYMBOLP (callback)) /* Show the binding of this command. */
482 /* #### Warning, dependency here on current_buffer and point */
483 where_is_to_char (callback, buf);
485 wv->key = xstrdup (buf);
490 CHECK_SYMBOL (style);
493 /* If the callback is nil, treat this item like unselectable text.
494 This way, dashes will show up as a separator. */
496 wv->type = BUTTON_TYPE;
497 if (separator_string_p (wv->name))
499 wv->type = SEPARATOR_TYPE;
500 wv->value = menu_separator_style (wv->name);
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 (style, Qbutton))
519 wv->type = BUTTON_TYPE;
520 else if (EQ (style, Qtoggle))
521 wv->type = TOGGLE_TYPE;
522 else if (EQ (style, Qradio))
523 wv->type = RADIO_TYPE;
524 else if (EQ (style, Qtext))
526 wv->type = TEXT_TYPE;
528 wv->value = wv->name;
533 signal_simple_error_2 ("Unknown style", style, desc);
535 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
536 signal_simple_error ("Text field not allowed in this context", desc);
538 if (selected_spec && EQ (style, Qtext))
539 signal_simple_error (
540 ":selected only makes sense with :style toggle, radio or button",
545 #endif /* HAVE_POPUPS */
547 /* This is a kludge to make sure emacs can only link against a version of
548 lwlib that was compiled in the right way. Emacs references symbols which
549 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
550 compiled in that way, then somewhat meaningful link errors will result.
551 The alternatives to this range from obscure link errors, to obscure
552 runtime errors that look a lot like bugs.
556 sanity_check_lwlib (void)
558 #define MACROLET(v) { extern int v; v = 1; }
560 #if (XlibSpecificationRelease == 4)
561 MACROLET (lwlib_uses_x11r4);
562 #elif (XlibSpecificationRelease == 5)
563 MACROLET (lwlib_uses_x11r5);
564 #elif (XlibSpecificationRelease == 6)
565 MACROLET (lwlib_uses_x11r6);
567 MACROLET (lwlib_uses_unknown_x11);
569 #ifdef LWLIB_USES_MOTIF
570 MACROLET (lwlib_uses_motif);
572 MACROLET (lwlib_does_not_use_motif);
574 #if (XmVersion >= 1002)
575 MACROLET (lwlib_uses_motif_1_2);
577 MACROLET (lwlib_does_not_use_motif_1_2);
579 #ifdef LWLIB_MENUBARS_LUCID
580 MACROLET (lwlib_menubars_lucid);
581 #elif defined (HAVE_MENUBARS)
582 MACROLET (lwlib_menubars_motif);
584 #ifdef LWLIB_SCROLLBARS_LUCID
585 MACROLET (lwlib_scrollbars_lucid);
586 #elif defined (LWLIB_SCROLLBARS_MOTIF)
587 MACROLET (lwlib_scrollbars_motif);
588 #elif defined (HAVE_SCROLLBARS)
589 MACROLET (lwlib_scrollbars_athena);
591 #ifdef LWLIB_DIALOGS_MOTIF
592 MACROLET (lwlib_dialogs_motif);
593 #elif defined (HAVE_DIALOGS)
594 MACROLET (lwlib_dialogs_athena);
604 defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
611 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
616 Vpopup_callbacks = Qnil;
617 staticpro (&Vpopup_callbacks);
620 /* This DEFVAR_LISP is just for the benefit of make-docfile. */
622 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
623 Function or functions to call when a menu or dialog box is dismissed
624 without a selection having been made.
627 Fset (Qmenu_no_selection_hook, Qnil);
628 #endif /* HAVE_POPUPS */
630 /* this makes only safe calls as in emacs.c */
631 sanity_check_lwlib ();