git.chise.org Git - chise/xemacs-chise.git.1/blob - src/gui.c

   1 /* Generic GUI code. (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 #include "gui.h"
  29 #include "elhash.h"
  30 #include "bytecode.h"
  31
  32 Lisp_Object Q_active, Q_suffix, Q_keys, Q_style, Q_selected;
  33 Lisp_Object Q_filter, Q_config, Q_included, Q_key_sequence;
  34 Lisp_Object Q_accelerator, Q_label, Q_callback;
  35 Lisp_Object Qtoggle, Qradio;
  36
  37 static Lisp_Object parse_gui_item_tree_list (Lisp_Object list);
  38
  39 #ifdef HAVE_POPUPS
  40
  41 /* count of menus/dboxes currently up */
  42 int popup_up_p;
  43
  44 DEFUN ("popup-up-p", Fpopup_up_p, 0, 0, 0, /*
  45 Return t if a popup menu or dialog box is up, nil otherwise.
  46 See `popup-menu' and `popup-dialog-box'.
  47 */
  48        ())
  49 {
  50   return popup_up_p ? Qt : Qnil;
  51 }
  52 #endif /* HAVE_POPUPS */
  53
  54 int
  55 separator_string_p (CONST char *s)
  56 {
  57   CONST char *p;
  58   char first;
  59
  60   if (!s || s[0] == '\0')
  61     return 0;
  62   first = s[0];
  63   if (first != '-' && first != '=')
  64     return 0;
  65   for (p = s; *p == first; p++)
  66     ;
  67
  68   return (*p == '!' || *p == ':' || *p == '\0');
  69 }
  70
  71 /* Massage DATA to find the correct function and argument.  Used by
  72    popup_selection_callback() and the msw code. */
  73 void
  74 get_gui_callback (Lisp_Object data, Lisp_Object *fn, Lisp_Object *arg)
  75 {
  76   if (SYMBOLP (data)
  77       || (COMPILED_FUNCTIONP (data)
  78           && XCOMPILED_FUNCTION (data)->flags.interactivep)
  79       || (CONSP (data) && (EQ (XCAR (data), Qlambda))
  80           && !NILP (Fassq (Qinteractive, Fcdr (Fcdr (data))))))
  81     {
  82       *fn = Qcall_interactively;
  83       *arg = data;
  84     }
  85   else if (CONSP (data))
  86     {
  87       *fn = Qeval;
  88       *arg = data;
  89     }
  90   else
  91     {
  92       *fn = Qeval;
  93       *arg = list3 (Qsignal,
  94                     list2 (Qquote, Qerror),
  95                     list2 (Qquote, list2 (build_translated_string
  96                                           ("illegal callback"),
  97                                           data)));
  98     }
  99 }
 100
 101 /*
 102  * Add a value VAL associated with keyword KEY into PGUI_ITEM
 103  * structure. If KEY is not a keyword, or is an unknown keyword, then
 104  * error is signaled.
 105  */
 106 void
 107 gui_item_add_keyval_pair (Lisp_Object gui_item,
 108                           Lisp_Object key, Lisp_Object val,
 109                           Error_behavior errb)
 110 {
 111   struct Lisp_Gui_Item* pgui_item = XGUI_ITEM (gui_item);
 112
 113   if (!KEYWORDP (key))
 114     signal_simple_error_2 ("Non-keyword in gui item", key, pgui_item->name);
 115
 116   if      (EQ (key, Q_suffix))   pgui_item->suffix   = val;
 117   else if (EQ (key, Q_active))   pgui_item->active   = val;
 118   else if (EQ (key, Q_included)) pgui_item->included = val;
 119   else if (EQ (key, Q_config))   pgui_item->config   = val;
 120   else if (EQ (key, Q_filter))   pgui_item->filter   = val;
 121   else if (EQ (key, Q_style))    pgui_item->style    = val;
 122   else if (EQ (key, Q_selected)) pgui_item->selected = val;
 123   else if (EQ (key, Q_keys))     pgui_item->keys     = val;
 124   else if (EQ (key, Q_callback))         pgui_item->callback     = val;
 125   else if (EQ (key, Q_key_sequence)) ;   /* ignored for FSF compatability */
 126   else if (EQ (key, Q_label)) ;   /* ignored for 21.0 implement in 21.2  */
 127   else if (EQ (key, Q_accelerator))
 128     {
 129       if (SYMBOLP (val) || CHARP (val))
 130         pgui_item->accelerator = val;
 131       else if (ERRB_EQ (errb, ERROR_ME))
 132         signal_simple_error ("Bad keyboard accelerator", val);
 133     }
 134   else if (ERRB_EQ (errb, ERROR_ME))
 135     signal_simple_error_2 ("Unknown keyword in gui item", key, pgui_item->name);
 136 }
 137
 138 void
 139 gui_item_init (Lisp_Object gui_item)
 140 {
 141   struct Lisp_Gui_Item *lp = XGUI_ITEM (gui_item);
 142
 143   lp->name     = Qnil;
 144   lp->callback = Qnil;
 145   lp->suffix   = Qnil;
 146   lp->active   = Qt;
 147   lp->included = Qt;
 148   lp->config   = Qnil;
 149   lp->filter   = Qnil;
 150   lp->style    = Qnil;
 151   lp->selected = Qnil;
 152   lp->keys     = Qnil;
 153   lp->accelerator     = Qnil;
 154 }
 155
 156 Lisp_Object
 157 allocate_gui_item (void)
 158 {
 159   struct Lisp_Gui_Item *lp =
 160     alloc_lcrecord_type (struct Lisp_Gui_Item, &lrecord_gui_item);
 161   Lisp_Object val;
 162
 163   zero_lcrecord (lp);
 164   XSETGUI_ITEM (val, lp);
 165
 166   gui_item_init (val);
 167
 168   return val;
 169 }
 170
 171 /*
 172  * ITEM is a lisp vector, describing a menu item or a button. The
 173  * function extracts the description of the item into the PGUI_ITEM
 174  * structure.
 175  */
 176 static Lisp_Object
 177 make_gui_item_from_keywords_internal (Lisp_Object item,
 178                                       Error_behavior errb)
 179 {
 180   int length, plist_p, start;
 181   Lisp_Object *contents;
 182   Lisp_Object gui_item = allocate_gui_item ();
 183   struct Lisp_Gui_Item* pgui_item = XGUI_ITEM (gui_item);
 184
 185   CHECK_VECTOR (item);
 186   length = XVECTOR_LENGTH (item);
 187   contents = XVECTOR_DATA (item);
 188
 189   if (length < 1)
 190     signal_simple_error ("GUI item descriptors must be at least 1 elts long", item);
 191
 192   /* length 1:                  [ "name" ]
 193      length 2:          [ "name" callback ]
 194      length 3:          [ "name" callback active-p ]
 195                    or   [ "name" keyword  value  ]
 196      length 4:          [ "name" callback active-p suffix ]
 197                    or   [ "name" callback keyword  value  ]
 198      length 5+:         [ "name" callback [ keyword value ]+ ]
 199                    or   [ "name" [ keyword value ]+ ]
 200   */
 201   plist_p = (length > 2 && (KEYWORDP (contents [1])
 202                             || KEYWORDP (contents [2])));
 203
 204   pgui_item->name = contents [0];
 205   if (length > 1 && !KEYWORDP (contents [1]))
 206     {
 207       pgui_item->callback = contents [1];
 208       start = 2;
 209     }
 210   else
 211     start =1;
 212
 213   if (!plist_p && length > 2)
 214     /* the old way */
 215     {
 216       pgui_item->active = contents [2];
 217       if (length == 4)
 218         pgui_item->suffix = contents [3];
 219     }
 220   else
 221     /* the new way */
 222     {
 223       int i;
 224       if ((length - start) & 1)
 225         signal_simple_error (
 226                 "GUI item descriptor has an odd number of keywords and values",
 227                              item);
 228
 229       for (i = start; i < length;)
 230         {
 231           Lisp_Object key = contents [i++];
 232           Lisp_Object val = contents [i++];
 233           gui_item_add_keyval_pair (gui_item, key, val, errb);
 234         }
 235     }
 236   return gui_item;
 237 }
 238
 239 Lisp_Object
 240 gui_parse_item_keywords (Lisp_Object item)
 241 {
 242   return make_gui_item_from_keywords_internal (item, ERROR_ME);
 243 }
 244
 245 Lisp_Object
 246 gui_parse_item_keywords_no_errors (Lisp_Object item)
 247 {
 248   return make_gui_item_from_keywords_internal (item, ERROR_ME_NOT);
 249 }
 250
 251 /* convert a gui item into plist properties */
 252 void
 253 gui_add_item_keywords_to_plist (Lisp_Object plist, Lisp_Object gui_item)
 254 {
 255   struct Lisp_Gui_Item* pgui_item = XGUI_ITEM (gui_item);
 256
 257   if (!NILP (pgui_item->callback))
 258     Fplist_put (plist, Q_callback, pgui_item->callback);
 259   if (!NILP (pgui_item->suffix))
 260     Fplist_put (plist, Q_suffix, pgui_item->suffix);
 261   if (!NILP (pgui_item->active))
 262     Fplist_put (plist, Q_active, pgui_item->active);
 263   if (!NILP (pgui_item->included))
 264     Fplist_put (plist, Q_included, pgui_item->included);
 265   if (!NILP (pgui_item->config))
 266     Fplist_put (plist, Q_config, pgui_item->config);
 267   if (!NILP (pgui_item->filter))
 268     Fplist_put (plist, Q_filter, pgui_item->filter);
 269   if (!NILP (pgui_item->style))
 270     Fplist_put (plist, Q_style, pgui_item->style);
 271   if (!NILP (pgui_item->selected))
 272     Fplist_put (plist, Q_selected, pgui_item->selected);
 273   if (!NILP (pgui_item->keys))
 274     Fplist_put (plist, Q_keys, pgui_item->keys);
 275   if (!NILP (pgui_item->accelerator))
 276     Fplist_put (plist, Q_accelerator, pgui_item->accelerator);
 277 }
 278
 279 /*
 280  * Decide whether a GUI item is active by evaluating its :active form
 281  * if any
 282  */
 283 int
 284 gui_item_active_p (Lisp_Object gui_item)
 285 {
 286   /* This function can call lisp */
 287
 288   /* Shortcut to avoid evaluating Qt each time */
 289   return (EQ (XGUI_ITEM (gui_item)->active, Qt)
 290           || !NILP (Feval (XGUI_ITEM (gui_item)->active)));
 291 }
 292
 293 /* set menu accelerator key to first underlined character in menu name */
 294 Lisp_Object
 295 gui_item_accelerator (Lisp_Object gui_item)
 296 {
 297   struct Lisp_Gui_Item* pgui = XGUI_ITEM (gui_item);
 298
 299   if (!NILP (pgui->accelerator))
 300     return pgui->accelerator;
 301
 302   else
 303     return pgui->name;
 304 }
 305
 306 Lisp_Object
 307 gui_name_accelerator (Lisp_Object nm)
 308 {
 309   /* !!#### This function has not been Mule-ized */
 310   char* name = (char*)XSTRING_DATA (nm);
 311
 312   while (*name) {
 313     if (*name=='%') {
 314       ++name;
 315       if (!(*name))
 316         return Qnil;
 317       if (*name=='_' && *(name+1))
 318         {
 319           int accelerator = (int) (unsigned char) (*(name+1));
 320           return make_char (tolower (accelerator));
 321         }
 322     }
 323     ++name;
 324   }
 325   return Qnil;
 326 }
 327
 328 /*
 329  * Decide whether a GUI item is selected by evaluating its :selected form
 330  * if any
 331  */
 332 int
 333 gui_item_selected_p (Lisp_Object gui_item)
 334 {
 335   /* This function can call lisp */
 336
 337   /* Shortcut to avoid evaluating Qt each time */
 338   return (EQ (XGUI_ITEM (gui_item)->selected, Qt)
 339           || !NILP (Feval (XGUI_ITEM (gui_item)->selected)));
 340 }
 341
 342 /*
 343  * Decide whether a GUI item is included by evaluating its :included
 344  * form if given, and testing its :config form against supplied CONFLIST
 345  * configuration variable
 346  */
 347 int
 348 gui_item_included_p (Lisp_Object gui_item, Lisp_Object conflist)
 349 {
 350   /* This function can call lisp */
 351   struct Lisp_Gui_Item* pgui_item = XGUI_ITEM (gui_item);
 352
 353   /* Evaluate :included first. Shortcut to avoid evaluating Qt each time */
 354   if (!EQ (pgui_item->included, Qt)
 355       && NILP (Feval (pgui_item->included)))
 356     return 0;
 357
 358   /* Do :config if conflist is given */
 359   if (!NILP (conflist) && !NILP (pgui_item->config)
 360       && NILP (Fmemq (pgui_item->config, conflist)))
 361     return 0;
 362
 363   return 1;
 364 }
 365
 366 static DOESNT_RETURN
 367 signal_too_long_error (Lisp_Object name)
 368 {
 369   signal_simple_error ("GUI item produces too long displayable string", name);
 370 }
 371
 372 #ifdef HAVE_WINDOW_SYSTEM
 373 /*
 374  * Format "left flush" display portion of an item into BUF, guarded by
 375  * maximum buffer size BUF_LEN. BUF_LEN does not count for terminating
 376  * null character, so actual maximum size of buffer consumed is
 377  * BUF_LEN + 1 bytes. If buffer is not big enough, then error is
 378  * signaled.
 379  * Return value is the offset to the terminating null character into the
 380  * buffer.
 381  */
 382 unsigned int
 383 gui_item_display_flush_left  (Lisp_Object gui_item,
 384                               char* buf, Bytecount buf_len)
 385 {
 386   /* This function can call lisp */
 387   char *p = buf;
 388   Bytecount len;
 389   struct Lisp_Gui_Item* pgui_item = XGUI_ITEM (gui_item);
 390
 391   /* Copy item name first */
 392   CHECK_STRING (pgui_item->name);
 393   len = XSTRING_LENGTH (pgui_item->name);
 394   if (len > buf_len)
 395     signal_too_long_error (pgui_item->name);
 396   memcpy (p, XSTRING_DATA (pgui_item->name), len);
 397   p += len;
 398
 399   /* Add space and suffix, if there is a suffix.
 400    * If suffix is not string evaluate it */
 401   if (!NILP (pgui_item->suffix))
 402     {
 403       Lisp_Object suffix = pgui_item->suffix;
 404       /* Shortcut to avoid evaluating suffix each time */
 405       if (!STRINGP (suffix))
 406         {
 407           suffix = Feval (suffix);
 408           CHECK_STRING (suffix);
 409         }
 410
 411       len = XSTRING_LENGTH (suffix);
 412       if (p + len + 1 > buf + buf_len)
 413         signal_too_long_error (pgui_item->name);
 414       *(p++) = ' ';
 415       memcpy (p, XSTRING_DATA (suffix), len);
 416       p += len;
 417     }
 418   *p = '\0';
 419   return p - buf;
 420 }
 421
 422 /*
 423  * Format "right flush" display portion of an item into BUF, guarded by
 424  * maximum buffer size BUF_LEN. BUF_LEN does not count for terminating
 425  * null character, so actual maximum size of buffer consumed is
 426  * BUF_LEN + 1 bytes. If buffer is not big enough, then error is
 427  * signaled.
 428  * Return value is the offset to the terminating null character into the
 429  * buffer.
 430  */
 431 unsigned int
 432 gui_item_display_flush_right (Lisp_Object gui_item,
 433                               char* buf, Bytecount buf_len)
 434 {
 435   struct Lisp_Gui_Item* pgui_item = XGUI_ITEM (gui_item);
 436   *buf = 0;
 437
 438 #ifdef HAVE_MENUBARS
 439   /* Have keys? */
 440   if (!menubar_show_keybindings)
 441     return 0;
 442 #endif
 443
 444   /* Try :keys first */
 445   if (!NILP (pgui_item->keys))
 446     {
 447       CHECK_STRING (pgui_item->keys);
 448       if (XSTRING_LENGTH (pgui_item->keys) > buf_len)
 449         signal_too_long_error (pgui_item->name);
 450       strcpy (buf, (CONST char *) XSTRING_DATA (pgui_item->keys));
 451       return XSTRING_LENGTH (pgui_item->keys);
 452     }
 453
 454   /* See if we can derive keys out of callback symbol */
 455   if (SYMBOLP (pgui_item->callback))
 456     {
 457       char buf2 [1024];
 458       Bytecount len;
 459
 460       where_is_to_char (pgui_item->callback, buf2);
 461       len = strlen (buf2);
 462       if (len > buf_len)
 463         signal_too_long_error (pgui_item->name);
 464       strcpy (buf, buf2);
 465       return len;
 466     }
 467
 468   /* No keys - no right flush display */
 469   return 0;
 470 }
 471 #endif /* HAVE_WINDOW_SYSTEM */
 472
 473 static Lisp_Object
 474 mark_gui_item (Lisp_Object obj)
 475 {
 476   struct Lisp_Gui_Item *p = XGUI_ITEM (obj);
 477
 478   mark_object (p->name);
 479   mark_object (p->callback);
 480   mark_object (p->config);
 481   mark_object (p->suffix);
 482   mark_object (p->active);
 483   mark_object (p->included);
 484   mark_object (p->config);
 485   mark_object (p->filter);
 486   mark_object (p->style);
 487   mark_object (p->selected);
 488   mark_object (p->keys);
 489   mark_object (p->accelerator);
 490
 491   return Qnil;
 492 }
 493
 494 static unsigned long
 495 gui_item_hash (Lisp_Object obj, int depth)
 496 {
 497   struct Lisp_Gui_Item *p = XGUI_ITEM (obj);
 498
 499   return HASH2 (HASH5 (internal_hash (p->name, depth + 1),
 500                        internal_hash (p->callback, depth + 1),
 501                        internal_hash (p->suffix, depth + 1),
 502                        internal_hash (p->active, depth + 1),
 503                        internal_hash (p->included, depth + 1)),
 504                 HASH5 (internal_hash (p->config, depth + 1),
 505                        internal_hash (p->filter, depth + 1),
 506                        internal_hash (p->style, depth + 1),
 507                        internal_hash (p->selected, depth + 1),
 508                        internal_hash (p->keys, depth + 1)));
 509 }
 510
 511 int
 512 gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot)
 513 {
 514   int hashid = gui_item_hash (gitem, 0);
 515   int id = GUI_ITEM_ID_BITS (hashid, slot);
 516   while (!NILP (Fgethash (make_int (id),
 517                           hashtable, Qnil)))
 518     {
 519       id = GUI_ITEM_ID_BITS (id + 1, slot);
 520     }
 521   return id;
 522 }
 523
 524 static int
 525 gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 526 {
 527   struct Lisp_Gui_Item *p1 = XGUI_ITEM (obj1);
 528   struct Lisp_Gui_Item *p2 = XGUI_ITEM (obj2);
 529
 530   if (!(internal_equal (p1->name, p2->name, depth + 1)
 531         &&
 532         internal_equal (p1->callback, p2->callback, depth + 1)
 533         &&
 534         EQ (p1->suffix, p2->suffix)
 535         &&
 536         EQ (p1->active, p2->active)
 537         &&
 538         EQ (p1->included, p2->included)
 539         &&
 540         EQ (p1->config, p2->config)
 541         &&
 542         EQ (p1->filter, p2->filter)
 543         &&
 544         EQ (p1->style, p2->style)
 545         &&
 546         EQ (p1->selected, p2->selected)
 547         &&
 548         EQ (p1->accelerator, p2->accelerator)
 549         &&
 550         EQ (p1->keys, p2->keys)))
 551     return 0;
 552   return 1;
 553 }
 554
 555 static void
 556 print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 557 {
 558   struct Lisp_Gui_Item *g = XGUI_ITEM (obj);
 559   char buf[20];
 560
 561   if (print_readably)
 562     error ("printing unreadable object #<gui-item 0x%x>", g->header.uid);
 563
 564   write_c_string ("#<gui-item ", printcharfun);
 565   sprintf (buf, "0x%x>", g->header.uid);
 566   write_c_string (buf, printcharfun);
 567 }
 568
 569 /* parse a glyph descriptor into a tree of gui items.
 570
 571    The gui_item slot of an image instance can be a single item or an
 572    arbitrarily nested hierarchy of item lists. */
 573
 574 static Lisp_Object parse_gui_item_tree_item (Lisp_Object entry)
 575 {
 576   Lisp_Object ret = entry;
 577   if (VECTORP (entry))
 578     {
 579       ret =  gui_parse_item_keywords_no_errors (entry);
 580     }
 581   else if (STRINGP (entry))
 582     {
 583       CHECK_STRING (entry);
 584     }
 585   else
 586     signal_simple_error ("item must be a vector or a string", entry);
 587
 588   return ret;
 589 }
 590
 591 Lisp_Object parse_gui_item_tree_children (Lisp_Object list)
 592 {
 593   Lisp_Object rest, ret = Qnil;
 594   CHECK_CONS (list);
 595   /* recursively add items to the tree view */
 596   LIST_LOOP (rest, list)
 597     {
 598       Lisp_Object sub;
 599       if (CONSP (XCAR (rest)))
 600         sub = parse_gui_item_tree_list (XCAR (rest));
 601       else
 602         sub = parse_gui_item_tree_item (XCAR (rest));
 603
 604       ret = Fcons (sub, ret);
 605     }
 606   /* make the order the same as the items we have parsed */
 607   return Fnreverse (ret);
 608 }
 609
 610 static Lisp_Object parse_gui_item_tree_list (Lisp_Object list)
 611 {
 612   Lisp_Object ret;
 613   CHECK_CONS (list);
 614   /* first one can never be a list */
 615   ret = parse_gui_item_tree_item (XCAR (list));
 616   return Fcons (ret, parse_gui_item_tree_children (XCDR (list)));
 617 }
 618
 619 DEFINE_LRECORD_IMPLEMENTATION ("gui-item", gui_item,
 620                                mark_gui_item, print_gui_item,
 621                                0, gui_item_equal,
 622                                gui_item_hash,
 623                                0,
 624                                struct Lisp_Gui_Item);
 625
 626 void
 627 syms_of_gui (void)
 628 {
 629   defkeyword (&Q_active,   ":active");
 630   defkeyword (&Q_suffix,   ":suffix");
 631   defkeyword (&Q_keys,     ":keys");
 632   defkeyword (&Q_key_sequence,":key-sequence");
 633   defkeyword (&Q_style,    ":style");
 634   defkeyword (&Q_selected, ":selected");
 635   defkeyword (&Q_filter,   ":filter");
 636   defkeyword (&Q_config,   ":config");
 637   defkeyword (&Q_included, ":included");
 638   defkeyword (&Q_accelerator, ":accelerator");
 639   defkeyword (&Q_label, ":label");
 640   defkeyword (&Q_callback, ":callback");
 641
 642   defsymbol (&Qtoggle, "toggle");
 643   defsymbol (&Qradio, "radio");
 644
 645 #ifdef HAVE_POPUPS
 646   DEFSUBR (Fpopup_up_p);
 647 #endif
 648 }
 649
 650 void
 651 vars_of_gui (void)
 652 {
 653 }