Mercurial > hg > xemacs-beta

comparison src/gui-x.c @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 080151679be2
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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.
6
7 This file is part of XEmacs.
8
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
12 later version.
13
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
17 for more details.
18
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. */
23
24 /* Synched up with: Not in FSF. */
25
26 #include <config.h>
27 #include "lisp.h"
28
29 #include "console-x.h"
30 #ifdef LWLIB_USES_MOTIF
31 #include <Xm/Xm.h> /* for XmVersion */
32 #endif
33 #include "gui-x.h"
34 #include "buffer.h"
35 #include "device.h"
36 #include "frame.h"
37 #include "gui.h"
38 #include "redisplay.h"
39 #include "opaque.h"
40
41 Lisp_Object Qmenu_no_selection_hook;
42
43 /* we need a unique id for each popup menu, dialog box, and scrollbar */
44 static unsigned int lwlib_id_tick;
45
46 LWLIB_ID
47 new_lwlib_id (void)
48 {
49 return ++lwlib_id_tick;
50 }
51
52 widget_value *
53 xmalloc_widget_value (void)
54 {
55 widget_value *tmp = malloc_widget_value ();
56 if (!tmp) memory_full ();
57 return tmp;
58 }
59
60
61 static int
62 mark_widget_value_mapper (widget_value *val, void *closure)
63 {
64 Lisp_Object markee;
65 if (val->call_data)
66 {
67 VOID_TO_LISP (markee, val->call_data);
68 mark_object (markee);
69 }
70
71 if (val->accel)
72 {
73 VOID_TO_LISP (markee, val->accel);
74 mark_object (markee);
75 }
76 return 0;
77 }
78
79 static Lisp_Object
80 mark_popup_data (Lisp_Object obj)
81 {
82 struct popup_data *data = (struct popup_data *) XPOPUP_DATA (obj);
83
84 /* Now mark the callbacks and such that are hidden in the lwlib
85 call-data */
86
87 if (data->id)
88 lw_map_widget_values (data->id, mark_widget_value_mapper, 0);
89
90 return data->last_menubar_buffer;
91 }
92
93 DEFINE_LRECORD_IMPLEMENTATION ("popup-data", popup_data,
94 mark_popup_data, internal_object_printer,
95 0, 0, 0, 0, struct popup_data);
96
97 /* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
98 (id . popup-data) for GCPRO'ing the callbacks of the popup menus
99 and dialog boxes. */
100 static Lisp_Object Vpopup_callbacks;
101
102 void
103 gcpro_popup_callbacks (LWLIB_ID id)
104 {
105 struct popup_data *pdata;
106 Lisp_Object lid = make_int (id);
107 Lisp_Object lpdata;
108
109 assert (NILP (assq_no_quit (lid, Vpopup_callbacks)));
110 pdata = alloc_lcrecord_type (struct popup_data, &lrecord_popup_data);
111 pdata->id = id;
112 pdata->last_menubar_buffer = Qnil;
113 pdata->menubar_contents_up_to_date = 0;
114 XSETPOPUP_DATA (lpdata, pdata);
115 Vpopup_callbacks = Fcons (Fcons (lid, lpdata), Vpopup_callbacks);
116 }
117
118 void
119 ungcpro_popup_callbacks (LWLIB_ID id)
120 {
121 Lisp_Object lid = make_int (id);
122 Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks);
123 assert (!NILP (this));
124 Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks);
125 }
126
127 int
128 popup_handled_p (LWLIB_ID id)
129 {
130 return NILP (assq_no_quit (make_int (id), Vpopup_callbacks));
131 }
132
133 /* menu_item_descriptor_to_widget_value() et al. mallocs a
134 widget_value, but then may signal lisp errors. If an error does
135 not occur, the opaque ptr we have here has had its pointer set to 0
136 to tell us not to do anything. Otherwise we free the widget value.
137 (This has nothing to do with GC, it's just about not dropping
138 pointers to malloc'd data when errors happen.) */
139
140 Lisp_Object
141 widget_value_unwind (Lisp_Object closure)
142 {
143 widget_value *wv = (widget_value *) get_opaque_ptr (closure);
144 free_opaque_ptr (closure);
145 if (wv)
146 free_widget_value (wv);
147 return Qnil;
148 }
149
150 #if 0
151 static void
152 print_widget_value (widget_value *wv, int depth)
153 {
154 /* !!#### This function has not been Mule-ized */
155 char d [200];
156 int i;
157 for (i = 0; i < depth; i++) d[i] = ' ';
158 d[depth]=0;
159 /* #### - print type field */
160 printf ("%sname: %s\n", d, (wv->name ? wv->name : "(null)"));
161 if (wv->value) printf ("%svalue: %s\n", d, wv->value);
162 if (wv->key) printf ("%skey: %s\n", d, wv->key);
163 printf ("%senabled: %d\n", d, wv->enabled);
164 if (wv->contents)
165 {
166 printf ("\n%scontents: \n", d);
167 print_widget_value (wv->contents, depth + 5);
168 }
169 if (wv->next)
170 {
171 printf ("\n");
172 print_widget_value (wv->next, depth);
173 }
174 }
175 #endif
176
177 /* This recursively calls free_widget_value() on the tree of widgets.
178 It must free all data that was malloc'ed for these widget_values.
179
180 It used to be that emacs only allocated new storage for the `key' slot.
181 All other slots are pointers into the data of Lisp_Strings, and must be
182 left alone. */
183 void
184 free_popup_widget_value_tree (widget_value *wv)
185 {
186 if (! wv) return;
187 if (wv->key) xfree (wv->key);
188 if (wv->value) xfree (wv->value);
189
190 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
191
192 if (wv->contents && (wv->contents != (widget_value*)1))
193 {
194 free_popup_widget_value_tree (wv->contents);
195 wv->contents = (widget_value *) 0xDEADBEEF;
196 }
197 if (wv->next)
198 {
199 free_popup_widget_value_tree (wv->next);
200 wv->next = (widget_value *) 0xDEADBEEF;
201 }
202 free_widget_value (wv);
203 }
204
205 /* The following is actually called from somewhere within XtDispatchEvent(),
206 called from XtAppProcessEvent() in event-Xt.c */
207
208 void
209 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
210 XtPointer client_data)
211 {
212 Lisp_Object fn, arg;
213 Lisp_Object data;
214 Lisp_Object frame;
215 struct device *d = get_device_from_display (XtDisplay (widget));
216 struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
217
218 /* set in lwlib to the time stamp associated with the most recent menu
219 operation */
220 extern Time x_focus_timestamp_really_sucks_fix_me_better;
221
222 if (!f)
223 return;
224 if (((EMACS_INT) client_data) == 0)
225 return;
226 VOID_TO_LISP (data, client_data);
227 XSETFRAME (frame, f);
228
229 #if 0
230 /* #### What the hell? I can't understand why this call is here,
231 and doing it is really courting disaster in the new event
232 model, since popup_selection_callback is called from
233 within next_event_internal() and Faccept_process_output()
234 itself calls next_event_internal(). --Ben */
235
236 /* Flush the X and process input */
237 Faccept_process_output (Qnil, Qnil, Qnil);
238 #endif
239
240 if (((EMACS_INT) client_data) == -1)
241 {
242 fn = Qrun_hooks;
243 arg = Qmenu_no_selection_hook;
244 }
245 else
246 {
247 MARK_SUBWINDOWS_STATE_CHANGED;
248 get_gui_callback (data, &fn, &arg);
249 }
250
251 /* This is the timestamp used for asserting focus so we need to get an
252 up-to-date value event if no events has been dispatched to emacs
253 */
254 #if defined(HAVE_MENUBARS)
255 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
256 #else
257 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
258 #endif
259 signal_special_Xt_user_event (frame, fn, arg);
260 }
261
262 #if 1
263 /* Eval the activep slot of the menu item */
264 # define wv_set_evalable_slot(slot,form) do { \
265 Lisp_Object wses_form = (form); \
266 (slot) = (NILP (wses_form) ? 0 : \
267 EQ (wses_form, Qt) ? 1 : \
268 !NILP (Feval (wses_form))); \
269 } while (0)
270 #else
271 /* Treat the activep slot of the menu item as a boolean */
272 # define wv_set_evalable_slot(slot,form) \
273 ((void) (slot = (!NILP (form))))
274 #endif
275
276 char *
277 menu_separator_style (CONST char *s)
278 {
279 CONST char *p;
280 char first;
281
282 if (!s || s[0] == '\0')
283 return NULL;
284 first = s[0];
285 if (first != '-' && first != '=')
286 return NULL;
287 for (p = s; *p == first; p++)
288 DO_NOTHING;
289
290 /* #### - cannot currently specify a separator tag "--!tag" and a
291 separator style "--:style" at the same time. */
292 /* #### - Also, the motif menubar code doesn't deal with the
293 double etched style yet, so it's not good to get into the habit of
294 using "===" in menubars to get double-etched lines */
295 if (*p == '!' || *p == '\0')
296 return ((first == '-')
297 ? NULL /* single etched is the default */
298 : xstrdup ("shadowDoubleEtchedIn"));
299 else if (*p == ':')
300 return xstrdup (p+1);
301
302 return NULL;
303 }
304
305
306 /* This does the dirty work. gc_currently_forbidden is 1 when this is called.
307 */
308 int
309 button_item_to_widget_value (Lisp_Object gui_item, widget_value *wv,
310 int allow_text_field_p, int no_keys_p)
311 {
312 /* !!#### This function has not been Mule-ized */
313 /* This function cannot GC because gc_currently_forbidden is set when
314 it's called */
315 struct Lisp_Gui_Item* pgui = 0;
316
317 /* degenerate case */
318 if (STRINGP (gui_item))
319 {
320 wv->type = TEXT_TYPE;
321 wv->name = (char *) XSTRING_DATA (gui_item);
322 wv->name = xstrdup (wv->name);
323 return 1;
324 }
325 else if (!GUI_ITEMP (gui_item))
326 signal_simple_error("need a string or a gui_item here", gui_item);
327
328 pgui = XGUI_ITEM (gui_item);
329
330 if (!NILP (pgui->filter))
331 signal_simple_error(":filter keyword not permitted on leaf nodes", gui_item);
332
333 #ifdef HAVE_MENUBARS
334 if (!gui_item_included_p (gui_item, Vmenubar_configuration))
335 {
336 /* the include specification says to ignore this item. */
337 return 0;
338 }
339 #endif /* HAVE_MENUBARS */
340
341 CHECK_STRING (pgui->name);
342 wv->name = (char *) XSTRING_DATA (pgui->name);
343 wv->name = xstrdup (wv->name);
344 wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
345
346 if (!NILP (pgui->suffix))
347 {
348 CONST char *const_bogosity;
349 Lisp_Object suffix2;
350
351 /* Shortcut to avoid evaluating suffix each time */
352 if (STRINGP (pgui->suffix))
353 suffix2 = pgui->suffix;
354 else
355 {
356 suffix2 = Feval (pgui->suffix);
357 CHECK_STRING (suffix2);
358 }
359
360 GET_C_STRING_FILENAME_DATA_ALLOCA (suffix2, const_bogosity);
361 wv->value = (char *) const_bogosity;
362 wv->value = xstrdup (wv->value);
363 }
364
365 wv_set_evalable_slot (wv->enabled, pgui->active);
366 wv_set_evalable_slot (wv->selected, pgui->selected);
367
368 if (!NILP (pgui->callback))
369 wv->call_data = LISP_TO_VOID (pgui->callback);
370
371 if (no_keys_p
372 #ifdef HAVE_MENUBARS
373 || !menubar_show_keybindings
374 #endif
375 )
376 wv->key = 0;
377 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */
378 {
379 CHECK_STRING (pgui->keys);
380 pgui->keys = Fsubstitute_command_keys (pgui->keys);
381 if (XSTRING_LENGTH (pgui->keys) > 0)
382 wv->key = xstrdup ((char *) XSTRING_DATA (pgui->keys));
383 else
384 wv->key = 0;
385 }
386 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */
387 {
388 char buf [1024];
389 /* #### Warning, dependency here on current_buffer and point */
390 where_is_to_char (pgui->callback, buf);
391 if (buf [0])
392 wv->key = xstrdup (buf);
393 else
394 wv->key = 0;
395 }
396
397 CHECK_SYMBOL (pgui->style);
398 if (NILP (pgui->style))
399 {
400 /* If the callback is nil, treat this item like unselectable text.
401 This way, dashes will show up as a separator. */
402 if (!wv->enabled)
403 wv->type = BUTTON_TYPE;
404 if (separator_string_p (wv->name))
405 {
406 wv->type = SEPARATOR_TYPE;
407 wv->value = menu_separator_style (wv->name);
408 }
409 else
410 {
411 #if 0
412 /* #### - this is generally desirable for menubars, but it breaks
413 a package that uses dialog boxes and next_command_event magic
414 to use the callback slot in dialog buttons for data instead of
415 a real callback.
416
417 Code is data, right? The beauty of LISP abuse. --Stig */
418 if (NILP (callback))
419 wv->type = TEXT_TYPE;
420 else
421 #endif
422 wv->type = BUTTON_TYPE;
423 }
424 }
425 else if (EQ (pgui->style, Qbutton))
426 wv->type = BUTTON_TYPE;
427 else if (EQ (pgui->style, Qtoggle))
428 wv->type = TOGGLE_TYPE;
429 else if (EQ (pgui->style, Qradio))
430 wv->type = RADIO_TYPE;
431 else if (EQ (pgui->style, Qtext))
432 {
433 wv->type = TEXT_TYPE;
434 #if 0
435 wv->value = wv->name;
436 wv->name = "value";
437 #endif
438 }
439 else
440 signal_simple_error_2 ("Unknown style", pgui->style, gui_item);
441
442 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
443 signal_simple_error ("Text field not allowed in this context", gui_item);
444
445 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
446 signal_simple_error (
447 ":selected only makes sense with :style toggle, radio or button",
448 gui_item);
449 return 1;
450 }
451
452 /* parse tree's of gui items into widget_value hierarchies */
453 static void gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent);
454
455 static widget_value *
456 gui_items_to_widget_values_1 (Lisp_Object items, widget_value* parent,
457 widget_value* prev)
458 {
459 widget_value* wv = 0;
460
461 assert ((parent || prev) && !(parent && prev));
462 /* now walk the tree creating widget_values as appropriate */
463 if (!CONSP (items))
464 {
465 wv = xmalloc_widget_value();
466 if (parent)
467 parent->contents = wv;
468 else
469 prev->next = wv;
470 if (!button_item_to_widget_value (items, wv, 0, 1))
471 {
472 free_widget_value (wv);
473 if (parent)
474 parent->contents = 0;
475 else
476 prev->next = 0;
477 }
478 else
479 {
480 wv->value = xstrdup (wv->name); /* what a mess... */
481 }
482 }
483 else
484 {
485 /* first one is the parent */
486 if (CONSP (XCAR (items)))
487 signal_simple_error ("parent item must not be a list", XCAR (items));
488
489 if (parent)
490 wv = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
491 else
492 wv = gui_items_to_widget_values_1 (XCAR (items), 0, prev);
493 /* the rest are the children */
494 gui_item_children_to_widget_values (XCDR (items), wv);
495 }
496 return wv;
497 }
498
499 static void
500 gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent)
501 {
502 widget_value* wv = 0, *prev = 0;
503 Lisp_Object rest;
504 CHECK_CONS (items);
505
506 /* first one is master */
507 prev = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
508 /* the rest are the children */
509 LIST_LOOP (rest, XCDR (items))
510 {
511 Lisp_Object tab = XCAR (rest);
512 wv = gui_items_to_widget_values_1 (tab, 0, prev);
513 prev = wv;
514 }
515 }
516
517 widget_value *
518 gui_items_to_widget_values (Lisp_Object items)
519 {
520 /* !!#### This function has not been Mule-ized */
521 /* This function can GC */
522 widget_value *control = 0, *tmp = 0;
523 int count = specpdl_depth ();
524 Lisp_Object wv_closure;
525
526 if (NILP (items))
527 signal_simple_error ("must have some items", items);
528
529 /* Inhibit GC during this conversion. The reasons for this are
530 the same as in menu_item_descriptor_to_widget_value(); see
531 the large comment above that function. */
532 record_unwind_protect (restore_gc_inhibit,
533 make_int (gc_currently_forbidden));
534 gc_currently_forbidden = 1;
535
536 /* Also make sure that we free the partially-created widget_value
537 tree on Lisp error. */
538 control = xmalloc_widget_value();
539 wv_closure = make_opaque_ptr (control);
540 record_unwind_protect (widget_value_unwind, wv_closure);
541
542 gui_items_to_widget_values_1 (items, control, 0);
543
544 /* mess about getting the data we really want */
545 tmp = control;
546 control = control->contents;
547 tmp->next = 0;
548 tmp->contents = 0;
549 free_widget_value (tmp);
550
551 /* No more need to free the half-filled-in structures. */
552 set_opaque_ptr (wv_closure, 0);
553 unbind_to (count, Qnil);
554
555 return control;
556 }
557
558 /* This is a kludge to make sure emacs can only link against a version of
559 lwlib that was compiled in the right way. Emacs references symbols which
560 correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
561 compiled in that way, then somewhat meaningful link errors will result.
562 The alternatives to this range from obscure link errors, to obscure
563 runtime errors that look a lot like bugs.
564 */
565
566 static void
567 sanity_check_lwlib (void)
568 {
569 #define MACROLET(v) { extern int v; v = 1; }
570
571 #if (XlibSpecificationRelease == 4)
572 MACROLET (lwlib_uses_x11r4);
573 #elif (XlibSpecificationRelease == 5)
574 MACROLET (lwlib_uses_x11r5);
575 #elif (XlibSpecificationRelease == 6)
576 MACROLET (lwlib_uses_x11r6);
577 #else
578 MACROLET (lwlib_uses_unknown_x11);
579 #endif
580 #ifdef LWLIB_USES_MOTIF
581 MACROLET (lwlib_uses_motif);
582 #else
583 MACROLET (lwlib_does_not_use_motif);
584 #endif
585 #if (XmVersion >= 1002)
586 MACROLET (lwlib_uses_motif_1_2);
587 #else
588 MACROLET (lwlib_does_not_use_motif_1_2);
589 #endif
590 #ifdef LWLIB_MENUBARS_LUCID
591 MACROLET (lwlib_menubars_lucid);
592 #elif defined (HAVE_MENUBARS)
593 MACROLET (lwlib_menubars_motif);
594 #endif
595 #ifdef LWLIB_SCROLLBARS_LUCID
596 MACROLET (lwlib_scrollbars_lucid);
597 #elif defined (LWLIB_SCROLLBARS_MOTIF)
598 MACROLET (lwlib_scrollbars_motif);
599 #elif defined (HAVE_SCROLLBARS)
600 MACROLET (lwlib_scrollbars_athena);
601 #endif
602 #ifdef LWLIB_DIALOGS_MOTIF
603 MACROLET (lwlib_dialogs_motif);
604 #elif defined (HAVE_DIALOGS)
605 MACROLET (lwlib_dialogs_athena);
606 #endif
607 #ifdef LWLIB_WIDGETS_MOTIF
608 MACROLET (lwlib_widgets_motif);
609 #elif defined (HAVE_WIDGETS)
610 MACROLET (lwlib_widgets_athena);
611 #endif
612
613 #undef MACROLET
614 }
615
616 void
617 syms_of_gui_x (void)
618 {
619 defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
620 }
621
622 void
623 reinit_vars_of_gui_x (void)
624 {
625 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
626 #ifdef HAVE_POPUPS
627 popup_up_p = 0;
628 #endif
629
630 /* this makes only safe calls as in emacs.c */
631 sanity_check_lwlib ();
632 }
633
634 void
635 vars_of_gui_x (void)
636 {
637 reinit_vars_of_gui_x ();
638
639 Vpopup_callbacks = Qnil;
640 staticpro (&Vpopup_callbacks);
641
642 #if 0
643 /* This DEFVAR_LISP is just for the benefit of make-docfile. */
644 /* #### misnamed */
645 DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
646 Function or functions to call when a menu or dialog box is dismissed
647 without a selection having been made.
648 */ );
649 #endif
650 Fset (Qmenu_no_selection_hook, Qnil);
651 }