428
+ − 1 /* General GUI code -- X-specific. (menubars, scrollbars, toolbars, dialogs)
+ − 2 Copyright (C) 1995 Board of Trustees, University of Illinois.
1261
+ − 3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003 Ben Wing.
428
+ − 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
442
+ − 26 /* This file Mule-ized by Ben Wing, 7-8-00. */
+ − 27
428
+ − 28 #include <config.h>
+ − 29 #include "lisp.h"
+ − 30
872
+ − 31 #include "buffer.h"
+ − 32 #include "device-impl.h"
+ − 33 #include "events.h"
+ − 34 #include "frame.h"
+ − 35 #include "glyphs.h"
+ − 36 #include "gui.h"
+ − 37 #include "menubar.h"
+ − 38 #include "opaque.h"
+ − 39 #include "redisplay.h"
+ − 40
+ − 41 #include "console-x-impl.h"
+ − 42
428
+ − 43 #ifdef LWLIB_USES_MOTIF
1315
+ − 44 #include "xmotif.h" /* for XmVersion */
428
+ − 45 #endif
+ − 46
+ − 47 /* we need a unique id for each popup menu, dialog box, and scrollbar */
647
+ − 48 static LWLIB_ID lwlib_id_tick;
428
+ − 49
+ − 50 LWLIB_ID
+ − 51 new_lwlib_id (void)
+ − 52 {
1346
+ − 53 lwlib_id_tick++;
+ − 54 if (!lwlib_id_tick)
+ − 55 lwlib_id_tick++;
+ − 56 return lwlib_id_tick;
428
+ − 57 }
+ − 58
+ − 59 widget_value *
+ − 60 xmalloc_widget_value (void)
+ − 61 {
+ − 62 widget_value *tmp = malloc_widget_value ();
+ − 63 if (!tmp) memory_full ();
+ − 64 return tmp;
+ − 65 }
+ − 66
+ − 67
1346
+ − 68
+ − 69 /* This contains an alist of (id . protect-me) for GCPRO'ing the callbacks
+ − 70 of the popup menus and dialog boxes. */
+ − 71 static Lisp_Object Vpopup_callbacks;
428
+ − 72
1346
+ − 73 struct widget_value_mapper
+ − 74 {
+ − 75 Lisp_Object protect_me;
1204
+ − 76 };
+ − 77
+ − 78 static int
+ − 79 snarf_widget_value_mapper (widget_value *val, void *closure)
+ − 80 {
1346
+ − 81 struct widget_value_mapper *z = (struct widget_value_mapper *) closure;
1204
+ − 82
+ − 83 if (val->call_data)
1346
+ − 84 z->protect_me = Fcons (VOID_TO_LISP (val->call_data), z->protect_me);
1204
+ − 85 if (val->accel)
1346
+ − 86 z->protect_me = Fcons (VOID_TO_LISP (val->accel), z->protect_me);
1204
+ − 87
+ − 88 return 0;
+ − 89 }
+ − 90
1261
+ − 91 /* Snarf the callbacks and other Lisp data that are hidden in the lwlib
1346
+ − 92 call-data and accel associated with id ID and return them for
+ − 93 proper marking. */
1261
+ − 94
1346
+ − 95 static Lisp_Object
+ − 96 snarf_widget_values_for_gcpro (LWLIB_ID id)
1261
+ − 97 {
1346
+ − 98 struct widget_value_mapper z;
1261
+ − 99
1346
+ − 100 z.protect_me = Qnil;
+ − 101 lw_map_widget_values (id, snarf_widget_value_mapper, &z);
+ − 102 return z.protect_me;
+ − 103 }
1261
+ − 104
1346
+ − 105 /* Given an lwlib id ID associated with a widget tree, make sure that all
+ − 106 Lisp callbacks in the tree are GC-protected. This can be called
+ − 107 multiple times on the same widget tree -- this should be done at
+ − 108 creation time and each time the tree is modified. */
1261
+ − 109
428
+ − 110 void
+ − 111 gcpro_popup_callbacks (LWLIB_ID id)
+ − 112 {
+ − 113 Lisp_Object lid = make_int (id);
2552
+ − 114 Lisp_Object this_callback = assq_no_quit (lid, Vpopup_callbacks);
428
+ − 115
2552
+ − 116 if (!NILP (this_callback))
1346
+ − 117 {
2552
+ − 118 free_list (XCDR (this_callback));
+ − 119 XCDR (this_callback) = snarf_widget_values_for_gcpro (id);
1346
+ − 120 }
+ − 121 else
+ − 122 Vpopup_callbacks = Fcons (Fcons (lid, snarf_widget_values_for_gcpro (id)),
+ − 123 Vpopup_callbacks);
+ − 124 }
1204
+ − 125
1346
+ − 126 /* Remove GC-protection from the just-destroyed widget tree associated
+ − 127 with lwlib id ID. */
428
+ − 128
+ − 129 void
+ − 130 ungcpro_popup_callbacks (LWLIB_ID id)
+ − 131 {
+ − 132 Lisp_Object lid = make_int (id);
2552
+ − 133 Lisp_Object this_callback = assq_no_quit (lid, Vpopup_callbacks);
1346
+ − 134
2552
+ − 135 assert (!NILP (this_callback));
+ − 136 free_list (XCDR (this_callback));
+ − 137 Vpopup_callbacks = delq_no_quit (this_callback, Vpopup_callbacks);
428
+ − 138 }
+ − 139
+ − 140 int
+ − 141 popup_handled_p (LWLIB_ID id)
+ − 142 {
+ − 143 return NILP (assq_no_quit (make_int (id), Vpopup_callbacks));
+ − 144 }
+ − 145
+ − 146 /* menu_item_descriptor_to_widget_value() et al. mallocs a
+ − 147 widget_value, but then may signal lisp errors. If an error does
+ − 148 not occur, the opaque ptr we have here has had its pointer set to 0
+ − 149 to tell us not to do anything. Otherwise we free the widget value.
+ − 150 (This has nothing to do with GC, it's just about not dropping
+ − 151 pointers to malloc'd data when errors happen.) */
+ − 152
+ − 153 Lisp_Object
+ − 154 widget_value_unwind (Lisp_Object closure)
+ − 155 {
+ − 156 widget_value *wv = (widget_value *) get_opaque_ptr (closure);
+ − 157 free_opaque_ptr (closure);
+ − 158 if (wv)
436
+ − 159 free_widget_value_tree (wv);
428
+ − 160 return Qnil;
+ − 161 }
+ − 162
+ − 163 #if 0
+ − 164 static void
+ − 165 print_widget_value (widget_value *wv, int depth)
+ − 166 {
442
+ − 167 /* strings in wv are in external format; use printf not stdout_out
+ − 168 because the latter takes internal-format strings */
+ − 169 Extbyte d [200];
428
+ − 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;
1726
+ − 201 if (wv->key) xfree (wv->key, char *);
+ − 202 if (wv->value) xfree (wv->value, char *);
+ − 203 if (wv->name) xfree (wv->name, char *);
428
+ − 204
1204
+ − 205 wv->name = wv->value = wv->key = (char *) 0xDEADBEEF; /* -559038737 base 10*/
428
+ − 206
+ − 207 if (wv->contents && (wv->contents != (widget_value*)1))
+ − 208 {
+ − 209 free_popup_widget_value_tree (wv->contents);
+ − 210 wv->contents = (widget_value *) 0xDEADBEEF;
+ − 211 }
+ − 212 if (wv->next)
+ − 213 {
+ − 214 free_popup_widget_value_tree (wv->next);
+ − 215 wv->next = (widget_value *) 0xDEADBEEF;
+ − 216 }
+ − 217 free_widget_value (wv);
+ − 218 }
+ − 219
+ − 220 /* The following is actually called from somewhere within XtDispatchEvent(),
2168
+ − 221 called from XtAppProcessEvent() in event-Xt.c.
+ − 222
+ − 223 Callback function for widgets and menus.
+ − 224 */
428
+ − 225
+ − 226 void
2286
+ − 227 popup_selection_callback (Widget widget, LWLIB_ID UNUSED (id),
428
+ − 228 XtPointer client_data)
+ − 229 {
442
+ − 230 Lisp_Object data, image_instance, callback, callback_ex;
+ − 231 Lisp_Object frame, event;
+ − 232 int update_subwindows_p = 0;
428
+ − 233 struct device *d = get_device_from_display (XtDisplay (widget));
+ − 234 struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
+ − 235
872
+ − 236 #ifdef HAVE_MENUBARS
428
+ − 237 /* set in lwlib to the time stamp associated with the most recent menu
+ − 238 operation */
+ − 239 extern Time x_focus_timestamp_really_sucks_fix_me_better;
872
+ − 240 #endif
428
+ − 241
+ − 242 if (!f)
+ − 243 return;
+ − 244 if (((EMACS_INT) client_data) == 0)
+ − 245 return;
826
+ − 246 data = VOID_TO_LISP (client_data);
793
+ − 247 frame = wrap_frame (f);
428
+ − 248
+ − 249 #if 0
+ − 250 /* #### What the hell? I can't understand why this call is here,
+ − 251 and doing it is really courting disaster in the new event
+ − 252 model, since popup_selection_callback is called from
+ − 253 within next_event_internal() and Faccept_process_output()
+ − 254 itself calls next_event_internal(). --Ben */
+ − 255
+ − 256 /* Flush the X and process input */
+ − 257 Faccept_process_output (Qnil, Qnil, Qnil);
+ − 258 #endif
+ − 259
+ − 260 if (((EMACS_INT) client_data) == -1)
+ − 261 {
442
+ − 262 event = Fmake_event (Qnil, Qnil);
+ − 263
934
+ − 264 XSET_EVENT_TYPE (event, misc_user_event);
+ − 265 XSET_EVENT_CHANNEL (event, frame);
1204
+ − 266 XSET_EVENT_MISC_USER_FUNCTION (event, Qrun_hooks);
+ − 267 XSET_EVENT_MISC_USER_OBJECT (event, Qmenu_no_selection_hook);
428
+ − 268 }
+ − 269 else
+ − 270 {
442
+ − 271 image_instance = XCAR (data);
+ − 272 callback = XCAR (XCDR (data));
+ − 273 callback_ex = XCDR (XCDR (data));
+ − 274 update_subwindows_p = 1;
+ − 275 /* It is possible for a widget action to cause it to get out of
+ − 276 sync with its instantiator. Thus it is necessary to signal
+ − 277 this possibility. */
+ − 278 if (IMAGE_INSTANCEP (image_instance))
+ − 279 XIMAGE_INSTANCE_WIDGET_ACTION_OCCURRED (image_instance) = 1;
+ − 280
+ − 281 if (!NILP (callback_ex) && !UNBOUNDP (callback_ex))
+ − 282 {
+ − 283 event = Fmake_event (Qnil, Qnil);
+ − 284
934
+ − 285 XSET_EVENT_TYPE (event, misc_user_event);
+ − 286 XSET_EVENT_CHANNEL (event, frame);
1204
+ − 287 XSET_EVENT_MISC_USER_FUNCTION (event, Qeval);
+ − 288 XSET_EVENT_MISC_USER_OBJECT (event, list4 (Qfuncall, callback_ex, image_instance, event));
442
+ − 289 }
+ − 290 else if (NILP (callback) || UNBOUNDP (callback))
+ − 291 event = Qnil;
+ − 292 else
+ − 293 {
+ − 294 Lisp_Object fn, arg;
+ − 295
+ − 296 event = Fmake_event (Qnil, Qnil);
+ − 297
+ − 298 get_gui_callback (callback, &fn, &arg);
934
+ − 299 XSET_EVENT_TYPE (event, misc_user_event);
+ − 300 XSET_EVENT_CHANNEL (event, frame);
1204
+ − 301 XSET_EVENT_MISC_USER_FUNCTION (event, fn);
+ − 302 XSET_EVENT_MISC_USER_OBJECT (event, arg);
442
+ − 303 }
428
+ − 304 }
+ − 305
+ − 306 /* This is the timestamp used for asserting focus so we need to get an
444
+ − 307 up-to-date value event if no events have been dispatched to emacs
428
+ − 308 */
872
+ − 309 #ifdef HAVE_MENUBARS
428
+ − 310 DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
+ − 311 #else
+ − 312 DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
+ − 313 #endif
442
+ − 314 if (!NILP (event))
1204
+ − 315 enqueue_dispatch_event (event);
442
+ − 316 /* The result of this evaluation could cause other instances to change so
+ − 317 enqueue an update callback to check this. */
+ − 318 if (update_subwindows_p && !NILP (event))
+ − 319 enqueue_magic_eval_event (update_widget_instances, frame);
428
+ − 320 }
+ − 321
+ − 322 #if 1
+ − 323 /* Eval the activep slot of the menu item */
1914
+ − 324 # define wv_set_evalable_slot(slot,form) do { \
+ − 325 Lisp_Object wses_form = (form); \
+ − 326 (slot) = (NILP (wses_form) ? 0 : \
+ − 327 EQ (wses_form, Qt) ? 1 : \
+ − 328 !NILP (in_display ? eval_within_redisplay (wses_form) \
+ − 329 : Feval (wses_form))); \
428
+ − 330 } while (0)
+ − 331 #else
+ − 332 /* Treat the activep slot of the menu item as a boolean */
+ − 333 # define wv_set_evalable_slot(slot,form) \
+ − 334 ((void) (slot = (!NILP (form))))
+ − 335 #endif
+ − 336
442
+ − 337 Extbyte *
867
+ − 338 menu_separator_style_and_to_external (const Ibyte *s)
428
+ − 339 {
867
+ − 340 const Ibyte *p;
+ − 341 Ibyte first;
428
+ − 342
+ − 343 if (!s || s[0] == '\0')
+ − 344 return NULL;
+ − 345 first = s[0];
+ − 346 if (first != '-' && first != '=')
+ − 347 return NULL;
+ − 348 for (p = s; *p == first; p++)
+ − 349 DO_NOTHING;
+ − 350
+ − 351 /* #### - cannot currently specify a separator tag "--!tag" and a
+ − 352 separator style "--:style" at the same time. */
+ − 353 /* #### - Also, the motif menubar code doesn't deal with the
+ − 354 double etched style yet, so it's not good to get into the habit of
+ − 355 using "===" in menubars to get double-etched lines */
+ − 356 if (*p == '!' || *p == '\0')
+ − 357 return ((first == '-')
+ − 358 ? NULL /* single etched is the default */
+ − 359 : xstrdup ("shadowDoubleEtchedIn"));
+ − 360 else if (*p == ':')
442
+ − 361 {
+ − 362 Extbyte *retval;
+ − 363
+ − 364 C_STRING_TO_EXTERNAL_MALLOC (p + 1, retval, Qlwlib_encoding);
+ − 365 return retval;
+ − 366 }
428
+ − 367
+ − 368 return NULL;
+ − 369 }
+ − 370
442
+ − 371 Extbyte *
+ − 372 add_accel_and_to_external (Lisp_Object string)
+ − 373 {
+ − 374 int i;
+ − 375 int found_accel = 0;
+ − 376 Extbyte *retval;
867
+ − 377 Ibyte *name = XSTRING_DATA (string);
442
+ − 378
+ − 379 for (i = 0; name[i]; ++i)
+ − 380 if (name[i] == '%' && name[i+1] == '_')
+ − 381 {
+ − 382 found_accel = 1;
+ − 383 break;
+ − 384 }
+ − 385
+ − 386 if (found_accel)
+ − 387 LISP_STRING_TO_EXTERNAL_MALLOC (string, retval, Qlwlib_encoding);
+ − 388 else
+ − 389 {
647
+ − 390 Bytecount namelen = XSTRING_LENGTH (string);
2367
+ − 391 Ibyte *chars = alloca_ibytes (namelen + 3);
442
+ − 392 chars[0] = '%';
+ − 393 chars[1] = '_';
+ − 394 memcpy (chars + 2, name, namelen + 1);
+ − 395 C_STRING_TO_EXTERNAL_MALLOC (chars, retval, Qlwlib_encoding);
+ − 396 }
+ − 397
+ − 398 return retval;
+ − 399 }
428
+ − 400
853
+ − 401 /* This does the dirty work. GC is inhibited when this is called.
+ − 402 */
428
+ − 403 int
442
+ − 404 button_item_to_widget_value (Lisp_Object gui_object_instance,
+ − 405 Lisp_Object gui_item, widget_value *wv,
+ − 406 int allow_text_field_p, int no_keys_p,
+ − 407 int menu_entry_p, int accel_p)
428
+ − 408 {
853
+ − 409 /* This function cannot GC because GC is inhibited when it's called */
440
+ − 410 Lisp_Gui_Item* pgui = 0;
428
+ − 411
+ − 412 /* degenerate case */
+ − 413 if (STRINGP (gui_item))
+ − 414 {
+ − 415 wv->type = TEXT_TYPE;
442
+ − 416 if (accel_p)
+ − 417 wv->name = add_accel_and_to_external (gui_item);
+ − 418 else
+ − 419 LISP_STRING_TO_EXTERNAL_MALLOC (gui_item, wv->name, Qlwlib_encoding);
428
+ − 420 return 1;
+ − 421 }
+ − 422 else if (!GUI_ITEMP (gui_item))
563
+ − 423 invalid_argument ("need a string or a gui_item here", gui_item);
428
+ − 424
+ − 425 pgui = XGUI_ITEM (gui_item);
+ − 426
+ − 427 if (!NILP (pgui->filter))
563
+ − 428 sferror (":filter keyword not permitted on leaf nodes", gui_item);
428
+ − 429
+ − 430 #ifdef HAVE_MENUBARS
442
+ − 431 if (menu_entry_p && !gui_item_included_p (gui_item, Vmenubar_configuration))
428
+ − 432 {
+ − 433 /* the include specification says to ignore this item. */
+ − 434 return 0;
+ − 435 }
+ − 436 #endif /* HAVE_MENUBARS */
+ − 437
442
+ − 438 if (!STRINGP (pgui->name))
+ − 439 pgui->name = Feval (pgui->name);
+ − 440
428
+ − 441 CHECK_STRING (pgui->name);
442
+ − 442 if (accel_p)
+ − 443 {
+ − 444 wv->name = add_accel_and_to_external (pgui->name);
+ − 445 wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
+ − 446 }
+ − 447 else
+ − 448 {
+ − 449 LISP_STRING_TO_EXTERNAL_MALLOC (pgui->name, wv->name, Qlwlib_encoding);
+ − 450 wv->accel = LISP_TO_VOID (Qnil);
+ − 451 }
428
+ − 452
+ − 453 if (!NILP (pgui->suffix))
+ − 454 {
+ − 455 Lisp_Object suffix2;
+ − 456
+ − 457 /* Shortcut to avoid evaluating suffix each time */
+ − 458 if (STRINGP (pgui->suffix))
+ − 459 suffix2 = pgui->suffix;
+ − 460 else
+ − 461 {
+ − 462 suffix2 = Feval (pgui->suffix);
+ − 463 CHECK_STRING (suffix2);
+ − 464 }
+ − 465
442
+ − 466 LISP_STRING_TO_EXTERNAL_MALLOC (suffix2, wv->value, Qlwlib_encoding);
428
+ − 467 }
+ − 468
+ − 469 wv_set_evalable_slot (wv->enabled, pgui->active);
+ − 470 wv_set_evalable_slot (wv->selected, pgui->selected);
+ − 471
442
+ − 472 if (!NILP (pgui->callback) || !NILP (pgui->callback_ex))
+ − 473 wv->call_data = LISP_TO_VOID (cons3 (gui_object_instance,
+ − 474 pgui->callback,
+ − 475 pgui->callback_ex));
428
+ − 476
+ − 477 if (no_keys_p
+ − 478 #ifdef HAVE_MENUBARS
442
+ − 479 || (menu_entry_p && !menubar_show_keybindings)
428
+ − 480 #endif
+ − 481 )
+ − 482 wv->key = 0;
+ − 483 else if (!NILP (pgui->keys)) /* Use this string to generate key bindings */
+ − 484 {
+ − 485 CHECK_STRING (pgui->keys);
+ − 486 pgui->keys = Fsubstitute_command_keys (pgui->keys);
+ − 487 if (XSTRING_LENGTH (pgui->keys) > 0)
442
+ − 488 LISP_STRING_TO_EXTERNAL_MALLOC (pgui->keys, wv->key, Qlwlib_encoding);
428
+ − 489 else
+ − 490 wv->key = 0;
+ − 491 }
+ − 492 else if (SYMBOLP (pgui->callback)) /* Show the binding of this command. */
+ − 493 {
793
+ − 494 DECLARE_EISTRING_MALLOC (buf);
428
+ − 495 /* #### Warning, dependency here on current_buffer and point */
+ − 496 where_is_to_char (pgui->callback, buf);
793
+ − 497 if (eilen (buf) > 0)
+ − 498 C_STRING_TO_EXTERNAL_MALLOC (eidata (buf), wv->key, Qlwlib_encoding);
428
+ − 499 else
+ − 500 wv->key = 0;
793
+ − 501 eifree (buf);
428
+ − 502 }
+ − 503
+ − 504 CHECK_SYMBOL (pgui->style);
+ − 505 if (NILP (pgui->style))
+ − 506 {
867
+ − 507 Ibyte *intname;
2286
+ − 508 Bytecount unused_intlen;
428
+ − 509 /* If the callback is nil, treat this item like unselectable text.
+ − 510 This way, dashes will show up as a separator. */
+ − 511 if (!wv->enabled)
+ − 512 wv->type = BUTTON_TYPE;
444
+ − 513 TO_INTERNAL_FORMAT (C_STRING, wv->name,
2286
+ − 514 ALLOCA, (intname, unused_intlen),
444
+ − 515 Qlwlib_encoding);
442
+ − 516 if (separator_string_p (intname))
428
+ − 517 {
+ − 518 wv->type = SEPARATOR_TYPE;
442
+ − 519 wv->value = menu_separator_style_and_to_external (intname);
428
+ − 520 }
+ − 521 else
+ − 522 {
+ − 523 #if 0
+ − 524 /* #### - this is generally desirable for menubars, but it breaks
+ − 525 a package that uses dialog boxes and next_command_event magic
+ − 526 to use the callback slot in dialog buttons for data instead of
+ − 527 a real callback.
+ − 528
+ − 529 Code is data, right? The beauty of LISP abuse. --Stig */
+ − 530 if (NILP (callback))
+ − 531 wv->type = TEXT_TYPE;
+ − 532 else
+ − 533 #endif
+ − 534 wv->type = BUTTON_TYPE;
+ − 535 }
+ − 536 }
+ − 537 else if (EQ (pgui->style, Qbutton))
+ − 538 wv->type = BUTTON_TYPE;
+ − 539 else if (EQ (pgui->style, Qtoggle))
+ − 540 wv->type = TOGGLE_TYPE;
+ − 541 else if (EQ (pgui->style, Qradio))
+ − 542 wv->type = RADIO_TYPE;
+ − 543 else if (EQ (pgui->style, Qtext))
+ − 544 {
+ − 545 wv->type = TEXT_TYPE;
+ − 546 #if 0
+ − 547 wv->value = wv->name;
+ − 548 wv->name = "value";
+ − 549 #endif
+ − 550 }
+ − 551 else
563
+ − 552 invalid_constant_2 ("Unknown style", pgui->style, gui_item);
428
+ − 553
+ − 554 if (!allow_text_field_p && (wv->type == TEXT_TYPE))
563
+ − 555 sferror ("Text field not allowed in this context", gui_item);
428
+ − 556
+ − 557 if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
563
+ − 558 sferror
442
+ − 559 (":selected only makes sense with :style toggle, radio or button",
+ − 560 gui_item);
428
+ − 561 return 1;
+ − 562 }
+ − 563
+ − 564 /* parse tree's of gui items into widget_value hierarchies */
442
+ − 565 static void gui_item_children_to_widget_values (Lisp_Object
+ − 566 gui_object_instance,
+ − 567 Lisp_Object items,
+ − 568 widget_value* parent,
+ − 569 int accel_p);
428
+ − 570
+ − 571 static widget_value *
442
+ − 572 gui_items_to_widget_values_1 (Lisp_Object gui_object_instance,
+ − 573 Lisp_Object items, widget_value* parent,
+ − 574 widget_value* prev, int accel_p)
428
+ − 575 {
+ − 576 widget_value* wv = 0;
+ − 577
+ − 578 assert ((parent || prev) && !(parent && prev));
+ − 579 /* now walk the tree creating widget_values as appropriate */
+ − 580 if (!CONSP (items))
+ − 581 {
442
+ − 582 wv = xmalloc_widget_value ();
428
+ − 583 if (parent)
+ − 584 parent->contents = wv;
440
+ − 585 else
428
+ − 586 prev->next = wv;
442
+ − 587 if (!button_item_to_widget_value (gui_object_instance,
+ − 588 items, wv, 0, 1, 0, accel_p))
428
+ − 589 {
436
+ − 590 free_widget_value_tree (wv);
428
+ − 591 if (parent)
+ − 592 parent->contents = 0;
440
+ − 593 else
428
+ − 594 prev->next = 0;
+ − 595 }
440
+ − 596 else
442
+ − 597 wv->value = xstrdup (wv->name); /* what a mess... */
428
+ − 598 }
+ − 599 else
+ − 600 {
+ − 601 /* first one is the parent */
+ − 602 if (CONSP (XCAR (items)))
563
+ − 603 sferror ("parent item must not be a list", XCAR (items));
428
+ − 604
+ − 605 if (parent)
442
+ − 606 wv = gui_items_to_widget_values_1 (gui_object_instance,
+ − 607 XCAR (items), parent, 0, accel_p);
428
+ − 608 else
442
+ − 609 wv = gui_items_to_widget_values_1 (gui_object_instance,
+ − 610 XCAR (items), 0, prev, accel_p);
428
+ − 611 /* the rest are the children */
442
+ − 612 gui_item_children_to_widget_values (gui_object_instance,
+ − 613 XCDR (items), wv, accel_p);
428
+ − 614 }
+ − 615 return wv;
+ − 616 }
+ − 617
+ − 618 static void
442
+ − 619 gui_item_children_to_widget_values (Lisp_Object gui_object_instance,
+ − 620 Lisp_Object items, widget_value* parent,
+ − 621 int accel_p)
428
+ − 622 {
+ − 623 widget_value* wv = 0, *prev = 0;
+ − 624 Lisp_Object rest;
+ − 625 CHECK_CONS (items);
+ − 626
+ − 627 /* first one is master */
442
+ − 628 prev = gui_items_to_widget_values_1 (gui_object_instance, XCAR (items),
+ − 629 parent, 0, accel_p);
428
+ − 630 /* the rest are the children */
+ − 631 LIST_LOOP (rest, XCDR (items))
+ − 632 {
+ − 633 Lisp_Object tab = XCAR (rest);
442
+ − 634 wv = gui_items_to_widget_values_1 (gui_object_instance, tab, 0, prev,
+ − 635 accel_p);
428
+ − 636 prev = wv;
+ − 637 }
+ − 638 }
+ − 639
+ − 640 widget_value *
442
+ − 641 gui_items_to_widget_values (Lisp_Object gui_object_instance, Lisp_Object items,
+ − 642 int accel_p)
428
+ − 643 {
+ − 644 /* This function can GC */
+ − 645 widget_value *control = 0, *tmp = 0;
771
+ − 646 int count;
428
+ − 647 Lisp_Object wv_closure;
+ − 648
+ − 649 if (NILP (items))
563
+ − 650 sferror ("must have some items", items);
428
+ − 651
+ − 652 /* Inhibit GC during this conversion. The reasons for this are
+ − 653 the same as in menu_item_descriptor_to_widget_value(); see
+ − 654 the large comment above that function. */
771
+ − 655 count = begin_gc_forbidden ();
428
+ − 656
+ − 657 /* Also make sure that we free the partially-created widget_value
+ − 658 tree on Lisp error. */
442
+ − 659 control = xmalloc_widget_value ();
428
+ − 660 wv_closure = make_opaque_ptr (control);
+ − 661 record_unwind_protect (widget_value_unwind, wv_closure);
+ − 662
442
+ − 663 gui_items_to_widget_values_1 (gui_object_instance, items, control, 0,
+ − 664 accel_p);
428
+ − 665
+ − 666 /* mess about getting the data we really want */
+ − 667 tmp = control;
+ − 668 control = control->contents;
+ − 669 tmp->next = 0;
+ − 670 tmp->contents = 0;
436
+ − 671 free_widget_value_tree (tmp);
428
+ − 672
+ − 673 /* No more need to free the half-filled-in structures. */
+ − 674 set_opaque_ptr (wv_closure, 0);
771
+ − 675 unbind_to (count);
428
+ − 676
+ − 677 return control;
+ − 678 }
+ − 679
+ − 680 void
+ − 681 syms_of_gui_x (void)
+ − 682 {
+ − 683 }
+ − 684
+ − 685 void
+ − 686 reinit_vars_of_gui_x (void)
+ − 687 {
+ − 688 lwlib_id_tick = (1<<16); /* start big, to not conflict with Energize */
+ − 689 #ifdef HAVE_POPUPS
+ − 690 popup_up_p = 0;
+ − 691 #endif
+ − 692 }
+ − 693
+ − 694 void
+ − 695 vars_of_gui_x (void)
+ − 696 {
+ − 697 Vpopup_callbacks = Qnil;
+ − 698 staticpro (&Vpopup_callbacks);
+ − 699 }
