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))
329 int accelerator = (int) (unsigned char) (*(name+1));
330 return make_char (tolower (accelerator));
338 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
342 button_item_to_widget_value (Lisp_Object desc, widget_value *wv,
343 int allow_text_field_p, int no_keys_p)
345 /* !!#### This function has not been Mule-ized */
346 /* This function cannot GC because gc_currently_forbidden is set when
348 Lisp_Object name = Qnil;
349 Lisp_Object callback = Qnil;
350 Lisp_Object suffix = Qnil;
351 Lisp_Object active_p = Qt;
352 Lisp_Object include_p = Qt;
353 Lisp_Object selected_p = Qnil;
354 Lisp_Object keys = Qnil;
355 Lisp_Object style = Qnil;
356 Lisp_Object config_tag = Qnil;
357 Lisp_Object accel = Qnil;
358 int length = XVECTOR_LENGTH (desc);
359 Lisp_Object *contents = XVECTOR_DATA (desc);
361 int selected_spec = 0, included_spec = 0;
364 signal_simple_error ("button descriptors must be at least 2 long", desc);
366 /* length 2: [ "name" callback ]
367 length 3: [ "name" callback active-p ]
368 length 4: [ "name" callback active-p suffix ]
369 or [ "name" callback keyword value ]
370 length 5+: [ "name" callback [ keyword value ]+ ]
372 plist_p = (length >= 5 || (length > 2 && KEYWORDP (contents [2])));
374 if (!plist_p && length > 2)
378 callback = contents [1];
379 active_p = contents [2];
381 suffix = contents [3];
388 signal_simple_error (
389 "button descriptor has an odd number of keywords and values",
393 callback = contents [1];
394 for (i = 2; i < length;)
396 Lisp_Object key = contents [i++];
397 Lisp_Object val = contents [i++];
399 signal_simple_error_2 ("not a keyword", key, desc);
401 if (EQ (key, Q_active)) active_p = val;
402 else if (EQ (key, Q_suffix)) suffix = val;
403 else if (EQ (key, Q_keys)) keys = val;
404 else if (EQ (key, Q_style)) style = val;
405 else if (EQ (key, Q_selected)) selected_p = val, selected_spec = 1;
406 else if (EQ (key, Q_included)) include_p = val, included_spec = 1;
407 else if (EQ (key, Q_config)) config_tag = val;
408 else if (EQ (key, Q_accelerator))
414 signal_simple_error ("bad keyboard accelerator", val);
416 else if (EQ (key, Q_filter))
417 signal_simple_error(":filter keyword not permitted on leaf nodes", desc);
419 signal_simple_error_2 ("unknown menu item keyword", key, desc);
424 if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration)))
425 || (included_spec && NILP (Feval (include_p))))
427 /* the include specification says to ignore this item. */
430 #endif /* HAVE_MENUBARS */
433 wv->name = (char *) XSTRING_DATA (name);
436 accel = menu_name_to_accelerator (wv->name);
437 wv->accel = LISP_TO_VOID (accel);
441 CONST char *const_bogosity;
444 /* Shortcut to avoid evaluating suffix each time */
445 if (STRINGP (suffix))
449 suffix2 = Feval (suffix);
450 CHECK_STRING (suffix2);
453 GET_C_STRING_FILENAME_DATA_ALLOCA (suffix2, const_bogosity);
454 wv->value = (char *) const_bogosity;
455 wv->value = xstrdup (wv->value);
458 wv_set_evalable_slot (wv->enabled, active_p);
459 wv_set_evalable_slot (wv->selected, selected_p);
461 wv->call_data = LISP_TO_VOID (callback);
465 || !menubar_show_keybindings
469 else if (!NILP (keys)) /* Use this string to generate key bindings */
472 keys = Fsubstitute_command_keys (keys);
473 if (XSTRING_LENGTH (keys) > 0)
474 wv->key = xstrdup ((char *) XSTRING_DATA (keys));
478 else if (SYMBOLP (callback)) /* Show the binding of this command. */
481 /* #### Warning, dependency here on current_buffer and point */
482 where_is_to_char (callback, buf);
484 wv->key = xstrdup (buf);
489 CHECK_SYMBOL (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 if (separator_string_p (wv->name))
498 wv->type = SEPARATOR_TYPE;
499 wv->value = menu_separator_style (wv->name);
504 /* #### - this is generally desirable for menubars, but it breaks
505 a package that uses dialog boxes and next_command_event magic
506 to use the callback slot in dialog buttons for data instead of
509 Code is data, right? The beauty of LISP abuse. --Stig */
511 wv->type = TEXT_TYPE;
514 wv->type = BUTTON_TYPE;
517 else if (EQ (style, Qbutton))
518 wv->type = BUTTON_TYPE;
519 else if (EQ (style, Qtoggle))
520 wv->type = TOGGLE_TYPE;
521 else if (EQ (style, Qradio))
522 wv->type = RADIO_TYPE;
523 else if (EQ (style, Qtext))
525 wv->type = TEXT_TYPE;
527 wv->value = wv->name;
532 signal_simple_error_2 ("unknown style", style, desc);
534 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
535 signal_simple_error ("text field not allowed in this context", desc);
537 if (selected_spec && EQ (style, Qtext))
538 signal_simple_error (
539 ":selected only makes sense with :style toggle, radio or button",
544 #endif /* HAVE_POPUPS */
546 /* This is a kludge to make sure emacs can only link against a version of
547 lwlib that was compiled in the right way. Emacs references symbols which
548 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
549 compiled in that way, then somewhat meaningful link errors will result.
550 The alternatives to this range from obscure link errors, to obscure
551 runtime errors that look a lot like bugs.
555 sanity_check_lwlib (void)
557 #define MACROLET(v) { extern int v; v = 1; }
559 #if (XlibSpecificationRelease == 4)
560 MACROLET (lwlib_uses_x11r4);
561 #elif (XlibSpecificationRelease == 5)
562 MACROLET (lwlib_uses_x11r5);
563 #elif (XlibSpecificationRelease == 6)
564 MACROLET (lwlib_uses_x11r6);
566 MACROLET (lwlib_uses_unknown_x11);
568 #ifdef LWLIB_USES_MOTIF
569 MACROLET (lwlib_uses_motif);
571 MACROLET (lwlib_does_not_use_motif);
573 #if (XmVersion >= 1002)
574 MACROLET (lwlib_uses_motif_1_2);
576 MACROLET (lwlib_does_not_use_motif_1_2);
578 #ifdef LWLIB_MENUBARS_LUCID
579 MACROLET (lwlib_menubars_lucid);
580 #elif defined (HAVE_MENUBARS)
581 MACROLET (lwlib_menubars_motif);
583 #ifdef LWLIB_SCROLLBARS_LUCID
584 MACROLET (lwlib_scrollbars_lucid);
585 #elif defined (LWLIB_SCROLLBARS_MOTIF)
586 MACROLET (lwlib_scrollbars_motif);
587 #elif defined (HAVE_SCROLLBARS)
588 MACROLET (lwlib_scrollbars_athena);
590 #ifdef LWLIB_DIALOGS_MOTIF
591 MACROLET (lwlib_dialogs_motif);
592 #elif defined (HAVE_DIALOGS)
593 MACROLET (lwlib_dialogs_athena);
603 defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
610 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
615 Vpopup_callbacks = Qnil;
616 staticpro (&Vpopup_callbacks);
619 /* This DEFVAR_LISP is just for the benefit of make-docfile. */
621 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
622 Function or functions to call when a menu or dialog box is dismissed
623 without a selection having been made.
626 Fset (Qmenu_no_selection_hook, Qnil);
627 #endif /* HAVE_POPUPS */
629 /* this makes only safe calls as in emacs.c */
630 sanity_check_lwlib ();