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 struct mark_widget_value_closure
  62 {
  63   void (*markobj) (Lisp_Object);
  64 };
  65
  66 static int
  67 mark_widget_value_mapper (widget_value *val, void *closure)
  68 {
  69   Lisp_Object markee;
  70
  71   struct mark_widget_value_closure *cl =
  72     (struct mark_widget_value_closure *) closure;
  73   if (val->call_data)
  74     {
  75       VOID_TO_LISP (markee, val->call_data);
  76       (cl->markobj) (markee);
  77     }
  78
  79   if (val->accel)
  80     {
  81       VOID_TO_LISP (markee, val->accel);
  82       (cl->markobj) (markee);
  83     }
  84   return 0;
  85 }
  86
  87 static Lisp_Object
  88 mark_popup_data (Lisp_Object obj, void (*markobj) (Lisp_Object))
  89 {
  90   struct popup_data *data = (struct popup_data *) XPOPUP_DATA (obj);
  91
  92   /* Now mark the callbacks and such that are hidden in the lwlib
  93      call-data */
  94
  95   if (data->id)
  96     {
  97       struct mark_widget_value_closure closure;
  98
  99       closure.markobj = markobj;
 100       lw_map_widget_values (data->id, mark_widget_value_mapper, &closure);
 101     }
 102
 103   return data->last_menubar_buffer;
 104 }
 105
 106 DEFINE_LRECORD_IMPLEMENTATION ("popup-data", popup_data,
 107                                mark_popup_data, internal_object_printer,
 108                                0, 0, 0, 0, struct popup_data);
 109 \f
 110 /* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
 111    (id . popup-data) for GCPRO'ing the callbacks of the popup menus
 112    and dialog boxes. */
 113 static Lisp_Object Vpopup_callbacks;
 114
 115 void
 116 gcpro_popup_callbacks (LWLIB_ID id)
 117 {
 118   struct popup_data *pdata;
 119   Lisp_Object lid = make_int (id);
 120   Lisp_Object lpdata;
 121
 122   assert (NILP (assq_no_quit (lid, Vpopup_callbacks)));
 123   pdata = alloc_lcrecord_type (struct popup_data, &lrecord_popup_data);
 124   pdata->id = id;
 125   pdata->last_menubar_buffer = Qnil;
 126   pdata->menubar_contents_up_to_date = 0;
 127   XSETPOPUP_DATA (lpdata, pdata);
 128   Vpopup_callbacks = Fcons (Fcons (lid, lpdata), Vpopup_callbacks);
 129 }
 130
 131 void
 132 ungcpro_popup_callbacks (LWLIB_ID id)
 133 {
 134   Lisp_Object lid = make_int (id);
 135   Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks);
 136   assert (!NILP (this));
 137   Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks);
 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)
 159     free_widget_value (wv);
 160   return Qnil;
 161 }
 162
 163 #if 0
 164 static void
 165 print_widget_value (widget_value *wv, int depth)
 166 {
 167   /* !!#### This function has not been Mule-ized */
 168   char d [200];
 169   int i;
 170   for (i = 0; i < depth; i++) d[i] = ' ';
 171   d[depth]=0;
 172   /* #### - print type field */
 173   printf ("%sname:    %s\n", d, (wv->name ? wv->name : "(null)"));
 174   if (wv->value) printf ("%svalue:   %s\n", d, wv->value);
 175   if (wv->key)   printf ("%skey:     %s\n", d, wv->key);
 176   printf ("%senabled: %d\n", d, wv->enabled);
 177   if (wv->contents)
 178     {
 179       printf ("\n%scontents: \n", d);
 180       print_widget_value (wv->contents, depth + 5);
 181     }
 182   if (wv->next)
 183     {
 184       printf ("\n");
 185       print_widget_value (wv->next, depth);
 186     }
 187 }
 188 #endif
 189
 190 /* This recursively calls free_widget_value() on the tree of widgets.
 191    It must free all data that was malloc'ed for these widget_values.
 192
 193    It used to be that emacs only allocated new storage for the `key' slot.
 194    All other slots are pointers into the data of Lisp_Strings, and must be
 195    left alone.  */
 196 void
 197 free_popup_widget_value_tree (widget_value *wv)
 198 {
 199   if (! wv) return;
 200   if (wv->key) xfree (wv->key);
 201   if (wv->value) xfree (wv->value);
 202
 203   wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
 204
 205   if (wv->contents && (wv->contents != (widget_value*)1))
 206     {
 207       free_popup_widget_value_tree (wv->contents);
 208       wv->contents = (widget_value *) 0xDEADBEEF;
 209     }
 210   if (wv->next)
 211     {
 212       free_popup_widget_value_tree (wv->next);
 213       wv->next = (widget_value *) 0xDEADBEEF;
 214     }
 215   free_widget_value (wv);
 216 }
 217
 218 /* The following is actually called from somewhere within XtDispatchEvent(),
 219    called from XtAppProcessEvent() in event-Xt.c */
 220
 221 void
 222 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
 223                           XtPointer client_data)
 224 {
 225   Lisp_Object fn, arg;
 226   Lisp_Object data;
 227   Lisp_Object frame;
 228   struct device *d = get_device_from_display (XtDisplay (widget));
 229   struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
 230
 231   /* set in lwlib to the time stamp associated with the most recent menu
 232      operation */
 233   extern Time x_focus_timestamp_really_sucks_fix_me_better;
 234
 235   if (!f)
 236     return;
 237   if (((EMACS_INT) client_data) == 0)
 238     return;
 239   VOID_TO_LISP (data, client_data);
 240   XSETFRAME (frame, f);
 241
 242 #if 0
 243   /* #### What the hell?  I can't understand why this call is here,
 244      and doing it is really courting disaster in the new event
 245      model, since popup_selection_callback is called from
 246      within next_event_internal() and Faccept_process_output()
 247      itself calls next_event_internal().  --Ben */
 248
 249   /* Flush the X and process input */
 250   Faccept_process_output (Qnil, Qnil, Qnil);
 251 #endif
 252
 253   if (((EMACS_INT) client_data) == -1)
 254     {
 255       fn = Qrun_hooks;
 256       arg = Qmenu_no_selection_hook;
 257     }
 258   else
 259     {
 260       MARK_SUBWINDOWS_CHANGED;
 261       get_gui_callback (data, &fn, &arg);
 262     }
 263
 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
 266      */
 267 #if defined(HAVE_MENUBARS)
 268   DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
 269 #else
 270   DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
 271 #endif
 272   signal_special_Xt_user_event (frame, fn, arg);
 273 }
 274
 275 #if 1
 276   /* Eval the activep slot of the menu item */
 277 # define wv_set_evalable_slot(slot,form) do {   \
 278   Lisp_Object wses_form = (form);               \
 279   (slot) = (NILP (wses_form) ? 0 :              \
 280             EQ (wses_form, Qt) ? 1 :            \
 281             !NILP (Feval (wses_form)));         \
 282 } while (0)
 283 #else
 284   /* Treat the activep slot of the menu item as a boolean */
 285 # define wv_set_evalable_slot(slot,form)        \
 286       ((void) (slot = (!NILP (form))))
 287 #endif
 288
 289 char *
 290 menu_separator_style (CONST char *s)
 291 {
 292   CONST char *p;
 293   char first;
 294
 295   if (!s || s[0] == '\0')
 296     return NULL;
 297   first = s[0];
 298   if (first != '-' && first != '=')
 299     return NULL;
 300   for (p = s; *p == first; p++)
 301     DO_NOTHING;
 302
 303   /* #### - cannot currently specify a separator tag "--!tag" and a
 304      separator style "--:style" at the same time. */
 305   /* #### - Also, the motif menubar code doesn't deal with the
 306      double etched style yet, so it's not good to get into the habit of
 307      using "===" in menubars to get double-etched lines */
 308   if (*p == '!' || *p == '\0')
 309     return ((first == '-')
 310             ? NULL                      /* single etched is the default */
 311             : xstrdup ("shadowDoubleEtchedIn"));
 312   else if (*p == ':')
 313     return xstrdup (p+1);
 314
 315   return NULL;
 316 }
 317
 318
 319 /* This does the dirty work.  gc_currently_forbidden is 1 when this is called.
 320  */
 321 int
 322 button_item_to_widget_value (Lisp_Object gui_item, widget_value *wv,
 323                              int allow_text_field_p, int no_keys_p)
 324 {
 325   /* !!#### This function has not been Mule-ized */
 326   /* This function cannot GC because gc_currently_forbidden is set when
 327      it's called */
 328   struct Lisp_Gui_Item* 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->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
 344
 345   if (!NILP (pgui->suffix))
 346     {
 347       CONST char *const_bogosity;
 348       Lisp_Object suffix2;
 349
 350       /* Shortcut to avoid evaluating suffix each time */
 351       if (STRINGP (pgui->suffix))
 352         suffix2 = pgui->suffix;
 353       else
 354         {
 355           suffix2 = Feval (pgui->suffix);
 356           CHECK_STRING (suffix2);
 357         }
 358
 359       GET_C_STRING_FILENAME_DATA_ALLOCA (suffix2, const_bogosity);
 360       wv->value = (char *) const_bogosity;
 361       wv->value = xstrdup (wv->value);
 362     }
 363
 364   wv_set_evalable_slot (wv->enabled, pgui->active);
 365   wv_set_evalable_slot (wv->selected, pgui->selected);
 366
 367   if (!NILP (pgui->callback))
 368     wv->call_data = LISP_TO_VOID (pgui->callback);
 369
 370   if (no_keys_p
 371 #ifdef HAVE_MENUBARS
 372       || !menubar_show_keybindings
 373 #endif
 374       )
 375     wv->key = 0;
 376   else if (!NILP (pgui->keys))  /* Use this string to generate key bindings */
 377     {
 378       CHECK_STRING (pgui->keys);
 379       pgui->keys = Fsubstitute_command_keys (pgui->keys);
 380       if (XSTRING_LENGTH (pgui->keys) > 0)
 381         wv->key = xstrdup ((char *) XSTRING_DATA (pgui->keys));
 382       else
 383         wv->key = 0;
 384     }
 385   else if (SYMBOLP (pgui->callback))    /* Show the binding of this command. */
 386     {
 387       char buf [1024];
 388       /* #### Warning, dependency here on current_buffer and point */
 389       where_is_to_char (pgui->callback, buf);
 390       if (buf [0])
 391         wv->key = xstrdup (buf);
 392       else
 393         wv->key = 0;
 394     }
 395
 396   CHECK_SYMBOL (pgui->style);
 397   if (NILP (pgui->style))
 398     {
 399       /* If the callback is nil, treat this item like unselectable text.
 400          This way, dashes will show up as a separator. */
 401       if (!wv->enabled)
 402         wv->type = BUTTON_TYPE;
 403       if (separator_string_p (wv->name))
 404         {
 405           wv->type = SEPARATOR_TYPE;
 406           wv->value = menu_separator_style (wv->name);
 407         }
 408       else
 409         {
 410 #if 0
 411           /* #### - this is generally desirable for menubars, but it breaks
 412              a package that uses dialog boxes and next_command_event magic
 413              to use the callback slot in dialog buttons for data instead of
 414              a real callback.
 415
 416              Code is data, right?  The beauty of LISP abuse.   --Stig */
 417           if (NILP (callback))
 418             wv->type = TEXT_TYPE;
 419           else
 420 #endif
 421             wv->type = BUTTON_TYPE;
 422         }
 423     }
 424   else if (EQ (pgui->style, Qbutton))
 425     wv->type = BUTTON_TYPE;
 426   else if (EQ (pgui->style, Qtoggle))
 427     wv->type = TOGGLE_TYPE;
 428   else if (EQ (pgui->style, Qradio))
 429     wv->type = RADIO_TYPE;
 430   else if (EQ (pgui->style, Qtext))
 431     {
 432       wv->type = TEXT_TYPE;
 433 #if 0
 434       wv->value = wv->name;
 435       wv->name = "value";
 436 #endif
 437     }
 438   else
 439     signal_simple_error_2 ("Unknown style", pgui->style, gui_item);
 440
 441   if (!allow_text_field_p && (wv->type == TEXT_TYPE))
 442     signal_simple_error ("Text field not allowed in this context", gui_item);
 443
 444   if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
 445     signal_simple_error (
 446                          ":selected only makes sense with :style toggle, radio or button",
 447                          gui_item);
 448   return 1;
 449 }
 450
 451
 452 /* This is a kludge to make sure emacs can only link against a version of
 453    lwlib that was compiled in the right way.  Emacs references symbols which
 454    correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
 455    compiled in that way, then somewhat meaningful link errors will result.
 456    The alternatives to this range from obscure link errors, to obscure
 457    runtime errors that look a lot like bugs.
 458  */
 459
 460 static void
 461 sanity_check_lwlib (void)
 462 {
 463 #define MACROLET(v) { extern int v; v = 1; }
 464
 465 #if (XlibSpecificationRelease == 4)
 466   MACROLET (lwlib_uses_x11r4);
 467 #elif (XlibSpecificationRelease == 5)
 468   MACROLET (lwlib_uses_x11r5);
 469 #elif (XlibSpecificationRelease == 6)
 470   MACROLET (lwlib_uses_x11r6);
 471 #else
 472   MACROLET (lwlib_uses_unknown_x11);
 473 #endif
 474 #ifdef LWLIB_USES_MOTIF
 475   MACROLET (lwlib_uses_motif);
 476 #else
 477   MACROLET (lwlib_does_not_use_motif);
 478 #endif
 479 #if (XmVersion >= 1002)
 480   MACROLET (lwlib_uses_motif_1_2);
 481 #else
 482   MACROLET (lwlib_does_not_use_motif_1_2);
 483 #endif
 484 #ifdef LWLIB_MENUBARS_LUCID
 485   MACROLET (lwlib_menubars_lucid);
 486 #elif defined (HAVE_MENUBARS)
 487   MACROLET (lwlib_menubars_motif);
 488 #endif
 489 #ifdef LWLIB_SCROLLBARS_LUCID
 490   MACROLET (lwlib_scrollbars_lucid);
 491 #elif defined (LWLIB_SCROLLBARS_MOTIF)
 492   MACROLET (lwlib_scrollbars_motif);
 493 #elif defined (HAVE_SCROLLBARS)
 494   MACROLET (lwlib_scrollbars_athena);
 495 #endif
 496 #ifdef LWLIB_DIALOGS_MOTIF
 497   MACROLET (lwlib_dialogs_motif);
 498 #elif defined (HAVE_DIALOGS)
 499   MACROLET (lwlib_dialogs_athena);
 500 #endif
 501
 502 #undef MACROLET
 503 }
 504
 505 void
 506 syms_of_gui_x (void)
 507 {
 508   defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
 509 }
 510
 511 void
 512 vars_of_gui_x (void)
 513 {
 514   lwlib_id_tick = (1<<16);      /* start big, to not conflict with Energize */
 515
 516   popup_up_p = 0;
 517
 518   Vpopup_callbacks = Qnil;
 519   staticpro (&Vpopup_callbacks);
 520
 521 #if 0
 522   /* This DEFVAR_LISP is just for the benefit of make-docfile. */
 523   /* #### misnamed */
 524   DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
 525 Function or functions to call when a menu or dialog box is dismissed
 526 without a selection having been made.
 527 */ );
 528 #endif
 529   Fset (Qmenu_no_selection_hook, Qnil);
 530
 531   /* this makes only safe calls as in emacs.c */
 532   sanity_check_lwlib ();
 533 }