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_tree (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   if (wv->name) xfree (wv->name);
 190
 191   wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
 192
 193   if (wv->contents && (wv->contents != (widget_value*)1))
 194     {
 195       free_popup_widget_value_tree (wv->contents);
 196       wv->contents = (widget_value *) 0xDEADBEEF;
 197     }
 198   if (wv->next)
 199     {
 200       free_popup_widget_value_tree (wv->next);
 201       wv->next = (widget_value *) 0xDEADBEEF;
 202     }
 203   free_widget_value (wv);
 204 }
 205
 206 /* The following is actually called from somewhere within XtDispatchEvent(),
 207    called from XtAppProcessEvent() in event-Xt.c */
 208
 209 void
 210 popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
 211                           XtPointer client_data)
 212 {
 213   Lisp_Object fn, arg;
 214   Lisp_Object data;
 215   Lisp_Object frame;
 216   struct device *d = get_device_from_display (XtDisplay (widget));
 217   struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
 218
 219   /* set in lwlib to the time stamp associated with the most recent menu
 220      operation */
 221   extern Time x_focus_timestamp_really_sucks_fix_me_better;
 222
 223   if (!f)
 224     return;
 225   if (((EMACS_INT) client_data) == 0)
 226     return;
 227   VOID_TO_LISP (data, client_data);
 228   XSETFRAME (frame, f);
 229
 230 #if 0
 231   /* #### What the hell?  I can't understand why this call is here,
 232      and doing it is really courting disaster in the new event
 233      model, since popup_selection_callback is called from
 234      within next_event_internal() and Faccept_process_output()
 235      itself calls next_event_internal().  --Ben */
 236
 237   /* Flush the X and process input */
 238   Faccept_process_output (Qnil, Qnil, Qnil);
 239 #endif
 240
 241   if (((EMACS_INT) client_data) == -1)
 242     {
 243       fn = Qrun_hooks;
 244       arg = Qmenu_no_selection_hook;
 245     }
 246   else
 247     {
 248       MARK_SUBWINDOWS_STATE_CHANGED;
 249       get_gui_callback (data, &fn, &arg);
 250     }
 251
 252   /* This is the timestamp used for asserting focus so we need to get an
 253      up-to-date value event if no events has been dispatched to emacs
 254      */
 255 #if defined(HAVE_MENUBARS)
 256   DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
 257 #else
 258   DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
 259 #endif
 260   signal_special_Xt_user_event (frame, fn, arg);
 261 }
 262
 263 #if 1
 264   /* Eval the activep slot of the menu item */
 265 # define wv_set_evalable_slot(slot,form) do {   \
 266   Lisp_Object wses_form = (form);               \
 267   (slot) = (NILP (wses_form) ? 0 :              \
 268             EQ (wses_form, Qt) ? 1 :            \
 269             !NILP (Feval (wses_form)));         \
 270 } while (0)
 271 #else
 272   /* Treat the activep slot of the menu item as a boolean */
 273 # define wv_set_evalable_slot(slot,form)        \
 274       ((void) (slot = (!NILP (form))))
 275 #endif
 276
 277 char *
 278 menu_separator_style (const char *s)
 279 {
 280   const char *p;
 281   char first;
 282
 283   if (!s || s[0] == '\0')
 284     return NULL;
 285   first = s[0];
 286   if (first != '-' && first != '=')
 287     return NULL;
 288   for (p = s; *p == first; p++)
 289     DO_NOTHING;
 290
 291   /* #### - cannot currently specify a separator tag "--!tag" and a
 292      separator style "--:style" at the same time. */
 293   /* #### - Also, the motif menubar code doesn't deal with the
 294      double etched style yet, so it's not good to get into the habit of
 295      using "===" in menubars to get double-etched lines */
 296   if (*p == '!' || *p == '\0')
 297     return ((first == '-')
 298             ? NULL                      /* single etched is the default */
 299             : xstrdup ("shadowDoubleEtchedIn"));
 300   else if (*p == ':')
 301     return xstrdup (p+1);
 302
 303   return NULL;
 304 }
 305
 306
 307 /* This does the dirty work.  gc_currently_forbidden is 1 when this is called.
 308  */
 309 int
 310 button_item_to_widget_value (Lisp_Object gui_item, widget_value *wv,
 311                              int allow_text_field_p, int no_keys_p)
 312 {
 313   /* !!#### This function has not been Mule-ized */
 314   /* This function cannot GC because gc_currently_forbidden is set when
 315      it's called */
 316   Lisp_Gui_Item* pgui = 0;
 317
 318   /* degenerate case */
 319   if (STRINGP (gui_item))
 320     {
 321       wv->type = TEXT_TYPE;
 322       wv->name = (char *) XSTRING_DATA (gui_item);
 323       wv->name = xstrdup (wv->name);
 324       return 1;
 325     }
 326   else if (!GUI_ITEMP (gui_item))
 327     signal_simple_error("need a string or a gui_item here", gui_item);
 328
 329   pgui = XGUI_ITEM (gui_item);
 330
 331   if (!NILP (pgui->filter))
 332     signal_simple_error(":filter keyword not permitted on leaf nodes", gui_item);
 333
 334 #ifdef HAVE_MENUBARS
 335   if (!gui_item_included_p (gui_item, Vmenubar_configuration))
 336     {
 337       /* the include specification says to ignore this item. */
 338       return 0;
 339     }
 340 #endif /* HAVE_MENUBARS */
 341
 342   CHECK_STRING (pgui->name);
 343   wv->name = (char *) XSTRING_DATA (pgui->name);
 344   wv->name = xstrdup (wv->name);
 345   wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
 346
 347   if (!NILP (pgui->suffix))
 348     {
 349       const char *const_bogosity;
 350       Lisp_Object suffix2;
 351
 352       /* Shortcut to avoid evaluating suffix each time */
 353       if (STRINGP (pgui->suffix))
 354         suffix2 = pgui->suffix;
 355       else
 356         {
 357           suffix2 = Feval (pgui->suffix);
 358           CHECK_STRING (suffix2);
 359         }
 360
 361       TO_EXTERNAL_FORMAT (LISP_STRING, suffix2,
 362                           C_STRING_ALLOCA, const_bogosity,
 363                           Qfile_name);
 364       wv->value = (char *) const_bogosity;
 365       wv->value = xstrdup (wv->value);
 366     }
 367
 368   wv_set_evalable_slot (wv->enabled, pgui->active);
 369   wv_set_evalable_slot (wv->selected, pgui->selected);
 370
 371   if (!NILP (pgui->callback))
 372     wv->call_data = LISP_TO_VOID (pgui->callback);
 373
 374   if (no_keys_p
 375 #ifdef HAVE_MENUBARS
 376       || !menubar_show_keybindings
 377 #endif
 378       )
 379     wv->key = 0;
 380   else if (!NILP (pgui->keys))  /* Use this string to generate key bindings */
 381     {
 382       CHECK_STRING (pgui->keys);
 383       pgui->keys = Fsubstitute_command_keys (pgui->keys);
 384       if (XSTRING_LENGTH (pgui->keys) > 0)
 385         wv->key = xstrdup ((char *) XSTRING_DATA (pgui->keys));
 386       else
 387         wv->key = 0;
 388     }
 389   else if (SYMBOLP (pgui->callback))    /* Show the binding of this command. */
 390     {
 391       char buf [1024];
 392       /* #### Warning, dependency here on current_buffer and point */
 393       where_is_to_char (pgui->callback, buf);
 394       if (buf [0])
 395         wv->key = xstrdup (buf);
 396       else
 397         wv->key = 0;
 398     }
 399
 400   CHECK_SYMBOL (pgui->style);
 401   if (NILP (pgui->style))
 402     {
 403       /* If the callback is nil, treat this item like unselectable text.
 404          This way, dashes will show up as a separator. */
 405       if (!wv->enabled)
 406         wv->type = BUTTON_TYPE;
 407       if (separator_string_p (wv->name))
 408         {
 409           wv->type = SEPARATOR_TYPE;
 410           wv->value = menu_separator_style (wv->name);
 411         }
 412       else
 413         {
 414 #if 0
 415           /* #### - this is generally desirable for menubars, but it breaks
 416              a package that uses dialog boxes and next_command_event magic
 417              to use the callback slot in dialog buttons for data instead of
 418              a real callback.
 419
 420              Code is data, right?  The beauty of LISP abuse.   --Stig */
 421           if (NILP (callback))
 422             wv->type = TEXT_TYPE;
 423           else
 424 #endif
 425             wv->type = BUTTON_TYPE;
 426         }
 427     }
 428   else if (EQ (pgui->style, Qbutton))
 429     wv->type = BUTTON_TYPE;
 430   else if (EQ (pgui->style, Qtoggle))
 431     wv->type = TOGGLE_TYPE;
 432   else if (EQ (pgui->style, Qradio))
 433     wv->type = RADIO_TYPE;
 434   else if (EQ (pgui->style, Qtext))
 435     {
 436       wv->type = TEXT_TYPE;
 437 #if 0
 438       wv->value = wv->name;
 439       wv->name = "value";
 440 #endif
 441     }
 442   else
 443     signal_simple_error_2 ("Unknown style", pgui->style, gui_item);
 444
 445   if (!allow_text_field_p && (wv->type == TEXT_TYPE))
 446     signal_simple_error ("Text field not allowed in this context", gui_item);
 447
 448   if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
 449     signal_simple_error (
 450                          ":selected only makes sense with :style toggle, radio or button",
 451                          gui_item);
 452   return 1;
 453 }
 454
 455 /* parse tree's of gui items into widget_value hierarchies */
 456 static void gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent);
 457
 458 static widget_value *
 459 gui_items_to_widget_values_1 (Lisp_Object items, widget_value* parent,
 460                               widget_value* prev)
 461 {
 462   widget_value* wv = 0;
 463
 464   assert ((parent || prev) && !(parent && prev));
 465   /* now walk the tree creating widget_values as appropriate */
 466   if (!CONSP (items))
 467     {
 468       wv = xmalloc_widget_value();
 469       if (parent)
 470         parent->contents = wv;
 471       else
 472         prev->next = wv;
 473       if (!button_item_to_widget_value (items, wv, 0, 1))
 474         {
 475           free_widget_value_tree (wv);
 476           if (parent)
 477             parent->contents = 0;
 478           else
 479             prev->next = 0;
 480         }
 481       else
 482         {
 483           wv->value = xstrdup (wv->name);       /* what a mess... */
 484         }
 485     }
 486   else
 487     {
 488       /* first one is the parent */
 489       if (CONSP (XCAR (items)))
 490         signal_simple_error ("parent item must not be a list", XCAR (items));
 491
 492       if (parent)
 493         wv = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
 494       else
 495         wv = gui_items_to_widget_values_1 (XCAR (items), 0, prev);
 496       /* the rest are the children */
 497       gui_item_children_to_widget_values (XCDR (items), wv);
 498     }
 499   return wv;
 500 }
 501
 502 static void
 503 gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent)
 504 {
 505   widget_value* wv = 0, *prev = 0;
 506   Lisp_Object rest;
 507   CHECK_CONS (items);
 508
 509   /* first one is master */
 510   prev = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
 511   /* the rest are the children */
 512   LIST_LOOP (rest, XCDR (items))
 513     {
 514       Lisp_Object tab = XCAR (rest);
 515       wv = gui_items_to_widget_values_1 (tab, 0, prev);
 516       prev = wv;
 517     }
 518 }
 519
 520 widget_value *
 521 gui_items_to_widget_values (Lisp_Object items)
 522 {
 523   /* !!#### This function has not been Mule-ized */
 524   /* This function can GC */
 525   widget_value *control = 0, *tmp = 0;
 526   int count = specpdl_depth ();
 527   Lisp_Object wv_closure;
 528
 529   if (NILP (items))
 530     signal_simple_error ("must have some items", items);
 531
 532   /* Inhibit GC during this conversion.  The reasons for this are
 533      the same as in menu_item_descriptor_to_widget_value(); see
 534      the large comment above that function. */
 535   record_unwind_protect (restore_gc_inhibit,
 536                          make_int (gc_currently_forbidden));
 537   gc_currently_forbidden = 1;
 538
 539   /* Also make sure that we free the partially-created widget_value
 540      tree on Lisp error. */
 541   control = xmalloc_widget_value();
 542   wv_closure = make_opaque_ptr (control);
 543   record_unwind_protect (widget_value_unwind, wv_closure);
 544
 545   gui_items_to_widget_values_1 (items, control, 0);
 546
 547   /* mess about getting the data we really want */
 548   tmp = control;
 549   control = control->contents;
 550   tmp->next = 0;
 551   tmp->contents = 0;
 552   free_widget_value_tree (tmp);
 553
 554   /* No more need to free the half-filled-in structures. */
 555   set_opaque_ptr (wv_closure, 0);
 556   unbind_to (count, Qnil);
 557
 558   return control;
 559 }
 560
 561 /* This is a kludge to make sure emacs can only link against a version of
 562    lwlib that was compiled in the right way.  Emacs references symbols which
 563    correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
 564    compiled in that way, then somewhat meaningful link errors will result.
 565    The alternatives to this range from obscure link errors, to obscure
 566    runtime errors that look a lot like bugs.
 567  */
 568
 569 static void
 570 sanity_check_lwlib (void)
 571 {
 572 #define MACROLET(v) { extern int v; v = 1; }
 573
 574 #if (XlibSpecificationRelease == 4)
 575   MACROLET (lwlib_uses_x11r4);
 576 #elif (XlibSpecificationRelease == 5)
 577   MACROLET (lwlib_uses_x11r5);
 578 #elif (XlibSpecificationRelease == 6)
 579   MACROLET (lwlib_uses_x11r6);
 580 #else
 581   MACROLET (lwlib_uses_unknown_x11);
 582 #endif
 583 #ifdef LWLIB_USES_MOTIF
 584   MACROLET (lwlib_uses_motif);
 585 #else
 586   MACROLET (lwlib_does_not_use_motif);
 587 #endif
 588 #if (XmVersion >= 1002)
 589   MACROLET (lwlib_uses_motif_1_2);
 590 #else
 591   MACROLET (lwlib_does_not_use_motif_1_2);
 592 #endif
 593 #ifdef LWLIB_MENUBARS_LUCID
 594   MACROLET (lwlib_menubars_lucid);
 595 #elif defined (HAVE_MENUBARS)
 596   MACROLET (lwlib_menubars_motif);
 597 #endif
 598 #ifdef LWLIB_SCROLLBARS_LUCID
 599   MACROLET (lwlib_scrollbars_lucid);
 600 #elif defined (LWLIB_SCROLLBARS_MOTIF)
 601   MACROLET (lwlib_scrollbars_motif);
 602 #elif defined (HAVE_SCROLLBARS)
 603   MACROLET (lwlib_scrollbars_athena);
 604 #endif
 605 #ifdef LWLIB_DIALOGS_MOTIF
 606   MACROLET (lwlib_dialogs_motif);
 607 #elif defined (HAVE_DIALOGS)
 608   MACROLET (lwlib_dialogs_athena);
 609 #endif
 610 #ifdef LWLIB_WIDGETS_MOTIF
 611   MACROLET (lwlib_widgets_motif);
 612 #elif defined (HAVE_WIDGETS)
 613   MACROLET (lwlib_widgets_athena);
 614 #endif
 615
 616 #undef MACROLET
 617 }
 618
 619 void
 620 syms_of_gui_x (void)
 621 {
 622   defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
 623 }
 624
 625 void
 626 reinit_vars_of_gui_x (void)
 627 {
 628   lwlib_id_tick = (1<<16);      /* start big, to not conflict with Energize */
 629 #ifdef HAVE_POPUPS
 630   popup_up_p = 0;
 631 #endif
 632
 633   /* this makes only safe calls as in emacs.c */
 634   sanity_check_lwlib ();
 635 }
 636
 637 void
 638 vars_of_gui_x (void)
 639 {
 640   reinit_vars_of_gui_x ();
 641
 642   Vpopup_callbacks = Qnil;
 643   staticpro (&Vpopup_callbacks);
 644
 645 #if 0
 646   /* This DEFVAR_LISP is just for the benefit of make-docfile. */
 647   /* #### misnamed */
 648   DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
 649 Function or functions to call when a menu or dialog box is dismissed
 650 without a selection having been made.
 651 */ );
 652 #endif
 653   Fset (Qmenu_no_selection_hook, Qnil);
 654 }