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         return make_char (tolower(*(name+1)));
 329     }
 330     ++name;
 331   }
 332   return Qnil;
 333 }
 334
 335 /* This does the dirty work.  gc_currently_forbidden is 1 when this is called.
 336  */
 337
 338 int
 339 button_item_to_widget_value (Lisp_Object desc, widget_value *wv,
 340                              int allow_text_field_p, int no_keys_p)
 341 {
 342   /* !!#### This function has not been Mule-ized */
 343   /* This function cannot GC because gc_currently_forbidden is set when
 344      it's called */
 345   Lisp_Object name       = Qnil;
 346   Lisp_Object callback   = Qnil;
 347   Lisp_Object suffix     = Qnil;
 348   Lisp_Object active_p   = Qt;
 349   Lisp_Object include_p  = Qt;
 350   Lisp_Object selected_p = Qnil;
 351   Lisp_Object keys       = Qnil;
 352   Lisp_Object style      = Qnil;
 353   Lisp_Object config_tag = Qnil;
 354   Lisp_Object accel = Qnil;
 355   int length = XVECTOR_LENGTH (desc);
 356   Lisp_Object *contents = XVECTOR_DATA (desc);
 357   int plist_p;
 358   int selected_spec = 0, included_spec = 0;
 359
 360   if (length < 2)
 361     signal_simple_error ("button descriptors must be at least 2 long", desc);
 362
 363   /* length 2:          [ "name" callback ]
 364      length 3:          [ "name" callback active-p ]
 365      length 4:          [ "name" callback active-p suffix ]
 366                    or   [ "name" callback keyword  value  ]
 367      length 5+:         [ "name" callback [ keyword value ]+ ]
 368    */
 369   plist_p = (length >= 5 || (length > 2 && KEYWORDP (contents [2])));
 370
 371   if (!plist_p && length > 2)
 372     /* the old way */
 373     {
 374       name = contents [0];
 375       callback = contents [1];
 376       active_p = contents [2];
 377       if (length == 4)
 378         suffix = contents [3];
 379     }
 380   else
 381     {
 382       /* the new way */
 383       int i;
 384       if (length & 1)
 385         signal_simple_error (
 386                 "button descriptor has an odd number of keywords and values",
 387                              desc);
 388
 389       name = contents [0];
 390       callback = contents [1];
 391       for (i = 2; i < length;)
 392         {
 393           Lisp_Object key = contents [i++];
 394           Lisp_Object val = contents [i++];
 395           if (!KEYWORDP (key))
 396             signal_simple_error_2 ("not a keyword", key, desc);
 397
 398           if      (EQ (key, Q_active))   active_p   = val;
 399           else if (EQ (key, Q_suffix))   suffix     = val;
 400           else if (EQ (key, Q_keys))     keys       = val;
 401           else if (EQ (key, Q_style))    style      = val;
 402           else if (EQ (key, Q_selected)) selected_p = val, selected_spec = 1;
 403           else if (EQ (key, Q_included)) include_p  = val, included_spec = 1;
 404           else if (EQ (key, Q_config))   config_tag = val;
 405           else if (EQ (key, Q_accelerator))
 406             {
 407               if ( SYMBOLP (val)
 408                    || CHARP (val))
 409                 accel = val;
 410               else
 411                 signal_simple_error ("bad keyboard accelerator", val);
 412             }
 413           else if (EQ (key, Q_filter))
 414             signal_simple_error(":filter keyword not permitted on leaf nodes", desc);
 415           else
 416             signal_simple_error_2 ("unknown menu item keyword", key, desc);
 417         }
 418     }
 419
 420 #ifdef HAVE_MENUBARS
 421   if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration)))
 422       || (included_spec && NILP (Feval (include_p))))
 423     {
 424       /* the include specification says to ignore this item. */
 425       return 0;
 426     }
 427 #endif /* HAVE_MENUBARS */
 428
 429   CHECK_STRING (name);
 430   wv->name = (char *) XSTRING_DATA (name);
 431
 432   if (NILP (accel))
 433     accel = menu_name_to_accelerator (wv->name);
 434   wv->accel = LISP_TO_VOID (accel);
 435
 436   if (!NILP (suffix))
 437     {
 438       CONST char *const_bogosity;
 439       Lisp_Object suffix2;
 440
 441       /* Shortcut to avoid evaluating suffix each time */
 442       if (STRINGP (suffix))
 443         suffix2 = suffix;
 444       else
 445         {
 446           suffix2 = Feval (suffix);
 447           CHECK_STRING (suffix2);
 448         }
 449
 450       GET_C_STRING_FILENAME_DATA_ALLOCA (suffix2, const_bogosity);
 451       wv->value = (char *) const_bogosity;
 452       wv->value = xstrdup (wv->value);
 453     }
 454
 455   wv_set_evalable_slot (wv->enabled, active_p);
 456   wv_set_evalable_slot (wv->selected, selected_p);
 457
 458   wv->call_data = LISP_TO_VOID (callback);
 459
 460   if (no_keys_p
 461 #ifdef HAVE_MENUBARS
 462       || !menubar_show_keybindings
 463 #endif
 464       )
 465     wv->key = 0;
 466   else if (!NILP (keys))        /* Use this string to generate key bindings */
 467     {
 468       CHECK_STRING (keys);
 469       keys = Fsubstitute_command_keys (keys);
 470       if (XSTRING_LENGTH (keys) > 0)
 471         wv->key = xstrdup ((char *) XSTRING_DATA (keys));
 472       else
 473         wv->key = 0;
 474     }
 475   else if (SYMBOLP (callback))  /* Show the binding of this command. */
 476     {
 477       char buf [1024];
 478       /* #### Warning, dependency here on current_buffer and point */
 479       where_is_to_char (callback, buf);
 480       if (buf [0])
 481         wv->key = xstrdup (buf);
 482       else
 483         wv->key = 0;
 484     }
 485
 486   CHECK_SYMBOL (style);
 487   if (NILP (style))
 488     {
 489       /* If the callback is nil, treat this item like unselectable text.
 490          This way, dashes will show up as a separator. */
 491       if (!wv->enabled)
 492         wv->type = BUTTON_TYPE;
 493       if (separator_string_p (wv->name))
 494         {
 495           wv->type = SEPARATOR_TYPE;
 496           wv->value = menu_separator_style (wv->name);
 497         }
 498       else
 499         {
 500 #if 0
 501           /* #### - this is generally desirable for menubars, but it breaks
 502              a package that uses dialog boxes and next_command_event magic
 503              to use the callback slot in dialog buttons for data instead of
 504              a real callback.
 505
 506              Code is data, right?  The beauty of LISP abuse.   --Stig */
 507           if (NILP (callback))
 508             wv->type = TEXT_TYPE;
 509           else
 510 #endif
 511             wv->type = BUTTON_TYPE;
 512         }
 513     }
 514   else if (EQ (style, Qbutton))
 515     wv->type = BUTTON_TYPE;
 516   else if (EQ (style, Qtoggle))
 517     wv->type = TOGGLE_TYPE;
 518   else if (EQ (style, Qradio))
 519     wv->type = RADIO_TYPE;
 520   else if (EQ (style, Qtext))
 521     {
 522       wv->type = TEXT_TYPE;
 523 #if 0
 524       wv->value = wv->name;
 525       wv->name = "value";
 526 #endif
 527     }
 528   else
 529     signal_simple_error_2 ("unknown style", style, desc);
 530
 531   if (!allow_text_field_p && (wv->type == TEXT_TYPE))
 532     signal_simple_error ("text field not allowed in this context", desc);
 533
 534   if (selected_spec && EQ (style, Qtext))
 535     signal_simple_error (
 536          ":selected only makes sense with :style toggle, radio or button",
 537                          desc);
 538   return 1;
 539 }
 540
 541 #endif /* HAVE_POPUPS */
 542
 543 /* This is a kludge to make sure emacs can only link against a version of
 544    lwlib that was compiled in the right way.  Emacs references symbols which
 545    correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
 546    compiled in that way, then somewhat meaningful link errors will result.
 547    The alternatives to this range from obscure link errors, to obscure
 548    runtime errors that look a lot like bugs.
 549  */
 550
 551 static void
 552 sanity_check_lwlib (void)
 553 {
 554 #define MACROLET(v) { extern int v; v = 1; }
 555
 556 #if (XlibSpecificationRelease == 4)
 557   MACROLET (lwlib_uses_x11r4);
 558 #elif (XlibSpecificationRelease == 5)
 559   MACROLET (lwlib_uses_x11r5);
 560 #elif (XlibSpecificationRelease == 6)
 561   MACROLET (lwlib_uses_x11r6);
 562 #else
 563   MACROLET (lwlib_uses_unknown_x11);
 564 #endif
 565 #ifdef LWLIB_USES_MOTIF
 566   MACROLET (lwlib_uses_motif);
 567 #else
 568   MACROLET (lwlib_does_not_use_motif);
 569 #endif
 570 #if (XmVersion >= 1002)
 571   MACROLET (lwlib_uses_motif_1_2);
 572 #else
 573   MACROLET (lwlib_does_not_use_motif_1_2);
 574 #endif
 575 #ifdef LWLIB_MENUBARS_LUCID
 576   MACROLET (lwlib_menubars_lucid);
 577 #elif defined (HAVE_MENUBARS)
 578   MACROLET (lwlib_menubars_motif);
 579 #endif
 580 #ifdef LWLIB_SCROLLBARS_LUCID
 581   MACROLET (lwlib_scrollbars_lucid);
 582 #elif defined (LWLIB_SCROLLBARS_MOTIF)
 583   MACROLET (lwlib_scrollbars_motif);
 584 #elif defined (HAVE_SCROLLBARS)
 585   MACROLET (lwlib_scrollbars_athena);
 586 #endif
 587 #ifdef LWLIB_DIALOGS_MOTIF
 588   MACROLET (lwlib_dialogs_motif);
 589 #elif defined (HAVE_DIALOGS)
 590   MACROLET (lwlib_dialogs_athena);
 591 #endif
 592
 593 #undef MACROLET
 594 }
 595
 596 void
 597 syms_of_gui_x (void)
 598 {
 599 #ifdef HAVE_POPUPS
 600   defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
 601 #endif
 602 }
 603
 604 void
 605 vars_of_gui_x (void)
 606 {
 607   lwlib_id_tick = (1<<16);      /* start big, to not conflict with Energize */
 608
 609 #ifdef HAVE_POPUPS
 610   popup_up_p = 0;
 611
 612   Vpopup_callbacks = Qnil;
 613   staticpro (&Vpopup_callbacks);
 614
 615 #if 0
 616   /* This DEFVAR_LISP is just for the benefit of make-docfile. */
 617   /* #### misnamed */
 618   DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
 619 Function or functions to call when a menu or dialog box is dismissed
 620 without a selection having been made.
 621 */ );
 622 #endif
 623   Fset (Qmenu_no_selection_hook, Qnil);
 624 #endif /* HAVE_POPUPS */
 625
 626   /* this makes only safe calls as in emacs.c */
 627   sanity_check_lwlib ();
 628 }