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 /* This file not quite Mule-ized yet but will be when merged with my
  27    Mule workspace. --ben */
  28
  29 #include <config.h>
  30 #include "lisp.h"
  31 #include "gui.h"
  32 #include "elhash.h"
  33 #include "buffer.h"
  34 #include "bytecode.h"
  35
  36 Lisp_Object Qmenu_no_selection_hook;
  37 Lisp_Object Vmenu_no_selection_hook;
  38
  39 static Lisp_Object parse_gui_item_tree_list (Lisp_Object list);
  40 Lisp_Object find_keyword_in_vector (Lisp_Object vector, Lisp_Object keyword);
  41
  42 #ifdef HAVE_POPUPS
  43
  44 /* count of menus/dboxes currently up */
  45 int popup_up_p;
  46
  47 DEFUN ("popup-up-p", Fpopup_up_p, 0, 0, 0, /*
  48 Return t if a popup menu or dialog box is up, nil otherwise.
  49 See `popup-menu' and `popup-dialog-box'.
  50 */
  51        ())
  52 {
  53   return popup_up_p ? Qt : Qnil;
  54 }
  55 #endif /* HAVE_POPUPS */
  56
  57 int
  58 separator_string_p (const Bufbyte *s)
  59 {
  60   const Bufbyte *p;
  61   Bufbyte first;
  62
  63   if (!s || s[0] == '\0')
  64     return 0;
  65   first = s[0];
  66   if (first != '-' && first != '=')
  67     return 0;
  68   for (p = s; *p == first; p++)
  69     ;
  70
  71   return (*p == '!' || *p == ':' || *p == '\0');
  72 }
  73
  74 /* Massage DATA to find the correct function and argument.  Used by
  75    popup_selection_callback() and the msw code. */
  76 void
  77 get_gui_callback (Lisp_Object data, Lisp_Object *fn, Lisp_Object *arg)
  78 {
  79   if (EQ (data, Qquit))
  80     {
  81       *fn = Qeval;
  82       *arg = list3 (Qsignal, list2 (Qquote, Qquit), Qnil);
  83       Vquit_flag = Qt;
  84     }
  85   else if (SYMBOLP (data)
  86            || (COMPILED_FUNCTIONP (data)
  87                && XCOMPILED_FUNCTION (data)->flags.interactivep)
  88            || (CONSP (data) && (EQ (XCAR (data), Qlambda))
  89                && !NILP (Fassq (Qinteractive, Fcdr (Fcdr (data))))))
  90     {
  91       *fn = Qcall_interactively;
  92       *arg = data;
  93     }
  94   else if (CONSP (data))
  95     {
  96       *fn = Qeval;
  97       *arg = data;
  98     }
  99   else
 100     {
 101       *fn = Qeval;
 102       *arg = list3 (Qsignal,
 103                     list2 (Qquote, Qerror),
 104                     list2 (Qquote, list2 (build_translated_string
 105                                           ("illegal callback"),
 106                                           data)));
 107     }
 108 }
 109
 110 /*
 111  * Add a value VAL associated with keyword KEY into PGUI_ITEM
 112  * structure. If KEY is not a keyword, or is an unknown keyword, then
 113  * error is signaled.
 114  */
 115 int
 116 gui_item_add_keyval_pair (Lisp_Object gui_item,
 117                           Lisp_Object key, Lisp_Object val,
 118                           Error_behavior errb)
 119 {
 120   Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
 121   int retval = 0;
 122
 123   if (!KEYWORDP (key))
 124     syntax_error_2 ("Non-keyword in gui item", key, pgui_item->name);
 125
 126   if (EQ (key, Q_descriptor))
 127     {
 128       if (!EQ (pgui_item->name, val))
 129         {
 130           retval = 1;
 131           pgui_item->name   = val;
 132         }
 133     }
 134 #define FROB(slot) \
 135   else if (EQ (key, Q_##slot))                  \
 136   {                                             \
 137     if (!EQ (pgui_item->slot, val))                     \
 138       {                                         \
 139         retval = 1;                             \
 140         pgui_item->slot   = val;                        \
 141       }                                         \
 142   }
 143   FROB (suffix)
 144   FROB (active)
 145   FROB (included)
 146   FROB (config)
 147   FROB (filter)
 148   FROB (style)
 149   FROB (selected)
 150   FROB (keys)
 151   FROB (callback)
 152   FROB (callback_ex)
 153   FROB (value)
 154 #undef FROB
 155   else if (EQ (key, Q_key_sequence)) ;   /* ignored for FSF compatibility */
 156   else if (EQ (key, Q_label)) ;   /* ignored for 21.0 implement in 21.2  */
 157   else if (EQ (key, Q_accelerator))
 158     {
 159       if (!EQ (pgui_item->accelerator, val))
 160         {
 161           retval = 1;
 162           if (SYMBOLP (val) || CHARP (val))
 163             pgui_item->accelerator = val;
 164           else if (ERRB_EQ (errb, ERROR_ME))
 165             syntax_error ("Bad keyboard accelerator", val);
 166         }
 167     }
 168   else if (ERRB_EQ (errb, ERROR_ME))
 169     syntax_error_2 ("Unknown keyword in gui item", key,
 170                            pgui_item->name);
 171   return retval;
 172 }
 173
 174 void
 175 gui_item_init (Lisp_Object gui_item)
 176 {
 177   Lisp_Gui_Item *lp = XGUI_ITEM (gui_item);
 178
 179   lp->name     = Qnil;
 180   lp->callback = Qnil;
 181   lp->callback_ex = Qnil;
 182   lp->suffix   = Qnil;
 183   lp->active   = Qt;
 184   lp->included = Qt;
 185   lp->config   = Qnil;
 186   lp->filter   = Qnil;
 187   lp->style    = Qnil;
 188   lp->selected = Qnil;
 189   lp->keys     = Qnil;
 190   lp->accelerator     = Qnil;
 191   lp->value = Qnil;
 192 }
 193
 194 Lisp_Object
 195 allocate_gui_item (void)
 196 {
 197   Lisp_Gui_Item *lp = alloc_lcrecord_type (Lisp_Gui_Item, &lrecord_gui_item);
 198   Lisp_Object val;
 199
 200   zero_lcrecord (lp);
 201   XSETGUI_ITEM (val, lp);
 202
 203   gui_item_init (val);
 204
 205   return val;
 206 }
 207
 208 /*
 209  * ITEM is a lisp vector, describing a menu item or a button. The
 210  * function extracts the description of the item into the PGUI_ITEM
 211  * structure.
 212  */
 213 static Lisp_Object
 214 make_gui_item_from_keywords_internal (Lisp_Object item,
 215                                       Error_behavior errb)
 216 {
 217   int length, plist_p, start;
 218   Lisp_Object *contents;
 219   Lisp_Object gui_item = allocate_gui_item ();
 220   Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
 221
 222   CHECK_VECTOR (item);
 223   length = XVECTOR_LENGTH (item);
 224   contents = XVECTOR_DATA (item);
 225
 226   if (length < 1)
 227     syntax_error ("GUI item descriptors must be at least 1 elts long", item);
 228
 229   /* length 1:                  [ "name" ]
 230      length 2:          [ "name" callback ]
 231      length 3:          [ "name" callback active-p ]
 232                    or   [ "name" keyword  value  ]
 233      length 4:          [ "name" callback active-p suffix ]
 234                    or   [ "name" callback keyword  value  ]
 235      length 5+:         [ "name" callback [ keyword value ]+ ]
 236                    or   [ "name" [ keyword value ]+ ]
 237   */
 238   plist_p = (length > 2 && (KEYWORDP (contents [1])
 239                             || KEYWORDP (contents [2])));
 240
 241   pgui_item->name = contents [0];
 242   if (length > 1 && !KEYWORDP (contents [1]))
 243     {
 244       pgui_item->callback = contents [1];
 245       start = 2;
 246     }
 247   else
 248     start =1;
 249
 250   if (!plist_p && length > 2)
 251     /* the old way */
 252     {
 253       pgui_item->active = contents [2];
 254       if (length == 4)
 255         pgui_item->suffix = contents [3];
 256     }
 257   else
 258     /* the new way */
 259     {
 260       int i;
 261       if ((length - start) & 1)
 262         syntax_error (
 263                 "GUI item descriptor has an odd number of keywords and values",
 264                              item);
 265
 266       for (i = start; i < length;)
 267         {
 268           Lisp_Object key = contents [i++];
 269           Lisp_Object val = contents [i++];
 270           gui_item_add_keyval_pair (gui_item, key, val, errb);
 271         }
 272     }
 273   return gui_item;
 274 }
 275
 276 /* This will only work with descriptors in the new format. */
 277 Lisp_Object
 278 widget_gui_parse_item_keywords (Lisp_Object item)
 279 {
 280   int i, length;
 281   Lisp_Object *contents;
 282   Lisp_Object gui_item = allocate_gui_item ();
 283   Lisp_Object desc = find_keyword_in_vector (item, Q_descriptor);
 284
 285   CHECK_VECTOR (item);
 286   length = XVECTOR_LENGTH (item);
 287   contents = XVECTOR_DATA (item);
 288
 289   if (!NILP (desc) && !STRINGP (desc) && !VECTORP (desc))
 290     syntax_error ("Invalid GUI item descriptor", item);
 291
 292   if (length & 1)
 293     {
 294       if (!SYMBOLP (contents [0]))
 295         syntax_error ("Invalid GUI item descriptor", item);
 296       contents++;                       /* Ignore the leading symbol. */
 297       length--;
 298     }
 299
 300   for (i = 0; i < length;)
 301     {
 302       Lisp_Object key = contents [i++];
 303       Lisp_Object val = contents [i++];
 304       gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_NOT);
 305     }
 306
 307   return gui_item;
 308 }
 309
 310 /* Update a gui item from a partial descriptor. */
 311 int
 312 update_gui_item_keywords (Lisp_Object gui_item, Lisp_Object item)
 313 {
 314   int i, length, retval = 0;
 315   Lisp_Object *contents;
 316
 317   CHECK_VECTOR (item);
 318   length = XVECTOR_LENGTH (item);
 319   contents = XVECTOR_DATA (item);
 320
 321  if (length & 1)
 322     {
 323       if (!SYMBOLP (contents [0]))
 324         syntax_error ("Invalid GUI item descriptor", item);
 325       contents++;                       /* Ignore the leading symbol. */
 326       length--;
 327     }
 328
 329   for (i = 0; i < length;)
 330     {
 331       Lisp_Object key = contents [i++];
 332       Lisp_Object val = contents [i++];
 333       if (gui_item_add_keyval_pair (gui_item, key, val, ERROR_ME_NOT))
 334         retval = 1;
 335     }
 336   return retval;
 337 }
 338
 339 Lisp_Object
 340 gui_parse_item_keywords (Lisp_Object item)
 341 {
 342   return make_gui_item_from_keywords_internal (item, ERROR_ME);
 343 }
 344
 345 Lisp_Object
 346 gui_parse_item_keywords_no_errors (Lisp_Object item)
 347 {
 348   return make_gui_item_from_keywords_internal (item, ERROR_ME_NOT);
 349 }
 350
 351 /* convert a gui item into plist properties */
 352 void
 353 gui_add_item_keywords_to_plist (Lisp_Object plist, Lisp_Object gui_item)
 354 {
 355   Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
 356
 357   if (!NILP (pgui_item->callback))
 358     Fplist_put (plist, Q_callback, pgui_item->callback);
 359   if (!NILP (pgui_item->callback_ex))
 360     Fplist_put (plist, Q_callback_ex, pgui_item->callback_ex);
 361   if (!NILP (pgui_item->suffix))
 362     Fplist_put (plist, Q_suffix, pgui_item->suffix);
 363   if (!NILP (pgui_item->active))
 364     Fplist_put (plist, Q_active, pgui_item->active);
 365   if (!NILP (pgui_item->included))
 366     Fplist_put (plist, Q_included, pgui_item->included);
 367   if (!NILP (pgui_item->config))
 368     Fplist_put (plist, Q_config, pgui_item->config);
 369   if (!NILP (pgui_item->filter))
 370     Fplist_put (plist, Q_filter, pgui_item->filter);
 371   if (!NILP (pgui_item->style))
 372     Fplist_put (plist, Q_style, pgui_item->style);
 373   if (!NILP (pgui_item->selected))
 374     Fplist_put (plist, Q_selected, pgui_item->selected);
 375   if (!NILP (pgui_item->keys))
 376     Fplist_put (plist, Q_keys, pgui_item->keys);
 377   if (!NILP (pgui_item->accelerator))
 378     Fplist_put (plist, Q_accelerator, pgui_item->accelerator);
 379   if (!NILP (pgui_item->value))
 380     Fplist_put (plist, Q_value, pgui_item->value);
 381 }
 382
 383 /*
 384  * Decide whether a GUI item is active by evaluating its :active form
 385  * if any
 386  */
 387 int
 388 gui_item_active_p (Lisp_Object gui_item)
 389 {
 390   /* This function can call lisp */
 391
 392   /* Shortcut to avoid evaluating Qt each time */
 393   return (EQ (XGUI_ITEM (gui_item)->active, Qt)
 394           || !NILP (Feval (XGUI_ITEM (gui_item)->active)));
 395 }
 396
 397 /* set menu accelerator key to first underlined character in menu name */
 398 Lisp_Object
 399 gui_item_accelerator (Lisp_Object gui_item)
 400 {
 401   Lisp_Gui_Item *pgui = XGUI_ITEM (gui_item);
 402
 403   if (!NILP (pgui->accelerator))
 404     return pgui->accelerator;
 405
 406   else
 407     return gui_name_accelerator (pgui->name);
 408 }
 409
 410 Lisp_Object
 411 gui_name_accelerator (Lisp_Object nm)
 412 {
 413   Bufbyte *name = XSTRING_DATA (nm);
 414
 415   while (*name)
 416     {
 417       if (*name == '%')
 418         {
 419           ++name;
 420           if (!(*name))
 421             return Qnil;
 422           if (*name == '_' && *(name + 1))
 423             {
 424               Emchar accelerator = charptr_emchar (name + 1);
 425               /* #### bogus current_buffer dependency */
 426               return make_char (DOWNCASE (current_buffer, accelerator));
 427             }
 428         }
 429         INC_CHARPTR (name);
 430     }
 431   return make_char (DOWNCASE (current_buffer,
 432                               charptr_emchar (XSTRING_DATA (nm))));
 433 }
 434
 435 /*
 436  * Decide whether a GUI item is selected by evaluating its :selected form
 437  * if any
 438  */
 439 int
 440 gui_item_selected_p (Lisp_Object gui_item)
 441 {
 442   /* This function can call lisp */
 443
 444   /* Shortcut to avoid evaluating Qt each time */
 445   return (EQ (XGUI_ITEM (gui_item)->selected, Qt)
 446           || !NILP (Feval (XGUI_ITEM (gui_item)->selected)));
 447 }
 448
 449 Lisp_Object
 450 gui_item_list_find_selected (Lisp_Object gui_item_list)
 451 {
 452   /* This function can GC. */
 453   Lisp_Object rest;
 454   LIST_LOOP (rest, gui_item_list)
 455     {
 456       if (gui_item_selected_p (XCAR (rest)))
 457         return XCAR (rest);
 458     }
 459   return XCAR (gui_item_list);
 460 }
 461
 462 /*
 463  * Decide whether a GUI item is included by evaluating its :included
 464  * form if given, and testing its :config form against supplied CONFLIST
 465  * configuration variable
 466  */
 467 int
 468 gui_item_included_p (Lisp_Object gui_item, Lisp_Object conflist)
 469 {
 470   /* This function can call lisp */
 471   Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
 472
 473   /* Evaluate :included first. Shortcut to avoid evaluating Qt each time */
 474   if (!EQ (pgui_item->included, Qt)
 475       && NILP (Feval (pgui_item->included)))
 476     return 0;
 477
 478   /* Do :config if conflist is given */
 479   if (!NILP (conflist) && !NILP (pgui_item->config)
 480       && NILP (Fmemq (pgui_item->config, conflist)))
 481     return 0;
 482
 483   return 1;
 484 }
 485
 486 static DOESNT_RETURN
 487 signal_too_long_error (Lisp_Object name)
 488 {
 489   syntax_error ("GUI item produces too long displayable string", name);
 490 }
 491
 492 #ifdef HAVE_WINDOW_SYSTEM
 493 /*
 494  * Format "left flush" display portion of an item into BUF, guarded by
 495  * maximum buffer size BUF_LEN. BUF_LEN does not count for terminating
 496  * null character, so actual maximum size of buffer consumed is
 497  * BUF_LEN + 1 bytes. If buffer is not big enough, then error is
 498  * signaled.
 499  * Return value is the offset to the terminating null character into the
 500  * buffer.
 501  */
 502 unsigned int
 503 gui_item_display_flush_left (Lisp_Object gui_item,
 504                              char *buf, Bytecount buf_len)
 505 {
 506   /* This function can call lisp */
 507   char *p = buf;
 508   Bytecount len;
 509   Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
 510
 511   /* Copy item name first */
 512   CHECK_STRING (pgui_item->name);
 513   len = XSTRING_LENGTH (pgui_item->name);
 514   if (len > buf_len)
 515     signal_too_long_error (pgui_item->name);
 516   memcpy (p, XSTRING_DATA (pgui_item->name), len);
 517   p += len;
 518
 519   /* Add space and suffix, if there is a suffix.
 520    * If suffix is not string evaluate it */
 521   if (!NILP (pgui_item->suffix))
 522     {
 523       Lisp_Object suffix = pgui_item->suffix;
 524       /* Shortcut to avoid evaluating suffix each time */
 525       if (!STRINGP (suffix))
 526         {
 527           suffix = Feval (suffix);
 528           CHECK_STRING (suffix);
 529         }
 530
 531       len = XSTRING_LENGTH (suffix);
 532       if (p + len + 1 > buf + buf_len)
 533         signal_too_long_error (pgui_item->name);
 534       *(p++) = ' ';
 535       memcpy (p, XSTRING_DATA (suffix), len);
 536       p += len;
 537     }
 538   *p = '\0';
 539   return p - buf;
 540 }
 541
 542 /*
 543  * Format "right flush" display portion of an item into BUF, guarded by
 544  * maximum buffer size BUF_LEN. BUF_LEN does not count for terminating
 545  * null character, so actual maximum size of buffer consumed is
 546  * BUF_LEN + 1 bytes. If buffer is not big enough, then error is
 547  * signaled.
 548  * Return value is the offset to the terminating null character into the
 549  * buffer.
 550  */
 551 unsigned int
 552 gui_item_display_flush_right (Lisp_Object gui_item,
 553                               char *buf, Bytecount buf_len)
 554 {
 555   Lisp_Gui_Item *pgui_item = XGUI_ITEM (gui_item);
 556   *buf = 0;
 557
 558 #ifdef HAVE_MENUBARS
 559   /* Have keys? */
 560   if (!menubar_show_keybindings)
 561     return 0;
 562 #endif
 563
 564   /* Try :keys first */
 565   if (!NILP (pgui_item->keys))
 566     {
 567       CHECK_STRING (pgui_item->keys);
 568       if (XSTRING_LENGTH (pgui_item->keys) + 1 > buf_len)
 569         signal_too_long_error (pgui_item->name);
 570       memcpy (buf, XSTRING_DATA (pgui_item->keys),
 571               XSTRING_LENGTH (pgui_item->keys) + 1);
 572       return XSTRING_LENGTH (pgui_item->keys);
 573     }
 574
 575   /* See if we can derive keys out of callback symbol */
 576   if (SYMBOLP (pgui_item->callback))
 577     {
 578       char buf2[1024]; /* #### */
 579       Bytecount len;
 580
 581       where_is_to_char (pgui_item->callback, buf2);
 582       len = strlen (buf2);
 583       if (len > buf_len)
 584         signal_too_long_error (pgui_item->name);
 585       strcpy (buf, buf2);
 586       return len;
 587     }
 588
 589   /* No keys - no right flush display */
 590   return 0;
 591 }
 592 #endif /* HAVE_WINDOW_SYSTEM */
 593
 594 static Lisp_Object
 595 mark_gui_item (Lisp_Object obj)
 596 {
 597   Lisp_Gui_Item *p = XGUI_ITEM (obj);
 598
 599   mark_object (p->name);
 600   mark_object (p->callback);
 601   mark_object (p->callback_ex);
 602   mark_object (p->config);
 603   mark_object (p->suffix);
 604   mark_object (p->active);
 605   mark_object (p->included);
 606   mark_object (p->config);
 607   mark_object (p->filter);
 608   mark_object (p->style);
 609   mark_object (p->selected);
 610   mark_object (p->keys);
 611   mark_object (p->accelerator);
 612   mark_object (p->value);
 613
 614   return Qnil;
 615 }
 616
 617 static unsigned long
 618 gui_item_hash (Lisp_Object obj, int depth)
 619 {
 620   Lisp_Gui_Item *p = XGUI_ITEM (obj);
 621
 622   return HASH2 (HASH6 (internal_hash (p->name, depth + 1),
 623                        internal_hash (p->callback, depth + 1),
 624                        internal_hash (p->callback_ex, depth + 1),
 625                        internal_hash (p->suffix, depth + 1),
 626                        internal_hash (p->active, depth + 1),
 627                        internal_hash (p->included, depth + 1)),
 628                 HASH6 (internal_hash (p->config, depth + 1),
 629                        internal_hash (p->filter, depth + 1),
 630                        internal_hash (p->style, depth + 1),
 631                        internal_hash (p->selected, depth + 1),
 632                        internal_hash (p->keys, depth + 1),
 633                        internal_hash (p->value, depth + 1)));
 634 }
 635
 636 int
 637 gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot)
 638 {
 639   int hashid = gui_item_hash (gitem, 0);
 640   int id = GUI_ITEM_ID_BITS (hashid, slot);
 641   while (!NILP (Fgethash (make_int (id),
 642                           hashtable, Qnil)))
 643     {
 644       id = GUI_ITEM_ID_BITS (id + 1, slot);
 645     }
 646   return id;
 647 }
 648
 649 int
 650 gui_item_equal_sans_selected (Lisp_Object obj1, Lisp_Object obj2, int depth)
 651 {
 652   Lisp_Gui_Item *p1 = XGUI_ITEM (obj1);
 653   Lisp_Gui_Item *p2 = XGUI_ITEM (obj2);
 654
 655   if (!(internal_equal (p1->name, p2->name, depth + 1)
 656         &&
 657         internal_equal (p1->callback, p2->callback, depth + 1)
 658         &&
 659         internal_equal (p1->callback_ex, p2->callback_ex, depth + 1)
 660         &&
 661         EQ (p1->suffix, p2->suffix)
 662         &&
 663         EQ (p1->active, p2->active)
 664         &&
 665         EQ (p1->included, p2->included)
 666         &&
 667         EQ (p1->config, p2->config)
 668         &&
 669         EQ (p1->filter, p2->filter)
 670         &&
 671         EQ (p1->style, p2->style)
 672         &&
 673         EQ (p1->accelerator, p2->accelerator)
 674         &&
 675         EQ (p1->keys, p2->keys)
 676         &&
 677         EQ (p1->value, p2->value)))
 678     return 0;
 679   return 1;
 680 }
 681
 682 static int
 683 gui_item_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 684 {
 685   Lisp_Gui_Item *p1 = XGUI_ITEM (obj1);
 686   Lisp_Gui_Item *p2 = XGUI_ITEM (obj2);
 687
 688   if (!(gui_item_equal_sans_selected (obj1, obj2, depth)
 689         &&
 690         EQ (p1->selected, p2->selected)))
 691     return 0;
 692   return 1;
 693 }
 694
 695 static void
 696 print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 697 {
 698   Lisp_Gui_Item *g = XGUI_ITEM (obj);
 699   char buf[20];
 700
 701   if (print_readably)
 702     error ("printing unreadable object #<gui-item 0x%x>", g->header.uid);
 703
 704   write_c_string ("#<gui-item ", printcharfun);
 705   sprintf (buf, "0x%x>", g->header.uid);
 706   write_c_string (buf, printcharfun);
 707 }
 708
 709 Lisp_Object
 710 copy_gui_item (Lisp_Object gui_item)
 711 {
 712   Lisp_Object  ret = allocate_gui_item ();
 713   Lisp_Gui_Item *lp, *g = XGUI_ITEM (gui_item);
 714
 715   lp = XGUI_ITEM (ret);
 716   lp->name     = g->name;
 717   lp->callback = g->callback;
 718   lp->callback_ex = g->callback_ex;
 719   lp->suffix   = g->suffix;
 720   lp->active   = g->active;
 721   lp->included = g->included;
 722   lp->config   = g->config;
 723   lp->filter   = g->filter;
 724   lp->style    = g->style;
 725   lp->selected = g->selected;
 726   lp->keys     = g->keys;
 727   lp->accelerator     = g->accelerator;
 728   lp->value = g->value;
 729
 730   return ret;
 731 }
 732
 733 Lisp_Object
 734 copy_gui_item_tree (Lisp_Object arg)
 735 {
 736   if (CONSP (arg))
 737     {
 738       Lisp_Object rest = arg = Fcopy_sequence (arg);
 739       while (CONSP (rest))
 740         {
 741           XCAR (rest) = copy_gui_item_tree (XCAR (rest));
 742           rest = XCDR (rest);
 743         }
 744       return arg;
 745     }
 746   else if (GUI_ITEMP (arg))
 747     return copy_gui_item (arg);
 748   else
 749     return arg;
 750 }
 751
 752 /* parse a glyph descriptor into a tree of gui items.
 753
 754    The gui_item slot of an image instance can be a single item or an
 755    arbitrarily nested hierarchy of item lists. */
 756
 757 static Lisp_Object
 758 parse_gui_item_tree_item (Lisp_Object entry)
 759 {
 760   Lisp_Object ret = entry;
 761   struct gcpro gcpro1;
 762
 763   GCPRO1 (ret);
 764
 765   if (VECTORP (entry))
 766     {
 767       ret = gui_parse_item_keywords_no_errors (entry);
 768     }
 769   else if (STRINGP (entry))
 770     {
 771       CHECK_STRING (entry);
 772     }
 773   else
 774     syntax_error ("item must be a vector or a string", entry);
 775
 776   RETURN_UNGCPRO (ret);
 777 }
 778
 779 Lisp_Object
 780 parse_gui_item_tree_children (Lisp_Object list)
 781 {
 782   Lisp_Object rest, ret = Qnil, sub = Qnil;
 783   struct gcpro gcpro1, gcpro2;
 784
 785   GCPRO2 (ret, sub);
 786   CHECK_CONS (list);
 787   /* recursively add items to the tree view */
 788   LIST_LOOP (rest, list)
 789     {
 790       if (CONSP (XCAR (rest)))
 791         sub = parse_gui_item_tree_list (XCAR (rest));
 792       else
 793         sub = parse_gui_item_tree_item (XCAR (rest));
 794
 795       ret = Fcons (sub, ret);
 796     }
 797   /* make the order the same as the items we have parsed */
 798   RETURN_UNGCPRO (Fnreverse (ret));
 799 }
 800
 801 static Lisp_Object
 802 parse_gui_item_tree_list (Lisp_Object list)
 803 {
 804   Lisp_Object ret;
 805   struct gcpro gcpro1;
 806   CHECK_CONS (list);
 807   /* first one can never be a list */
 808   ret = parse_gui_item_tree_item (XCAR (list));
 809   GCPRO1 (ret);
 810   ret = Fcons (ret, parse_gui_item_tree_children (XCDR (list)));
 811   RETURN_UNGCPRO (ret);
 812 }
 813
 814 static void
 815 finalize_gui_item (void* header, int for_disksave)
 816 {
 817 }
 818
 819 DEFINE_LRECORD_IMPLEMENTATION ("gui-item", gui_item,
 820                                mark_gui_item, print_gui_item,
 821                                finalize_gui_item, gui_item_equal,
 822                                gui_item_hash,
 823                                0,
 824                                Lisp_Gui_Item);
 825
 826 void
 827 syms_of_gui (void)
 828 {
 829   INIT_LRECORD_IMPLEMENTATION (gui_item);
 830
 831   DEFSYMBOL (Qmenu_no_selection_hook);
 832
 833 #ifdef HAVE_POPUPS
 834   DEFSUBR (Fpopup_up_p);
 835 #endif
 836 }
 837
 838 void
 839 vars_of_gui (void)
 840 {
 841   DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
 842 Function or functions to call when a menu or dialog box is dismissed
 843 without a selection having been made.
 844 */ );
 845   Vmenu_no_selection_hook = Qnil;
 846 }