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