git.chise.org Git - chise/xemacs-chise.git.1/blob - src/gui-x.c

   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 \f
  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 \f
  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 }