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