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