comparison src/gui-x.c @ 0:376386a54a3c r19-14

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