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.
7 This file is part of SXEmacs
9 SXEmacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 SXEmacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 /* Synched up with: Not in FSF. */
25 /* This file not quite Mule-ized yet but will be when merged with my
26 Mule workspace. --ben */
35 Lisp_Object Qmenu_no_selection_hook;
36 Lisp_Object Vmenu_no_selection_hook;
38 static Lisp_Object parse_gui_item_tree_list(Lisp_Object list);
39 Lisp_Object find_keyword_in_vector(Lisp_Object vector, Lisp_Object keyword);
43 /* count of menus/dboxes currently up */
46 DEFUN("popup-up-p", Fpopup_up_p, 0, 0, 0, /*
47 Return t if a popup menu or dialog box is up, nil otherwise.
48 See `popup-menu' and `popup-dialog-box'.
52 return popup_up_p ? Qt : Qnil;
54 #endif /* HAVE_POPUPS */
56 int separator_string_p(const Bufbyte * s)
61 if (!s || s[0] == '\0')
64 if (first != '-' && first != '=')
66 for (p = s; *p == first; p++) ;
68 return (*p == '!' || *p == ':' || *p == '\0');
71 /* Massage DATA to find the correct function and argument. Used by
72 popup_selection_callback() and the msw code. */
73 void get_gui_callback(Lisp_Object data, Lisp_Object * fn, Lisp_Object * arg)
75 if (EQ(data, Qquit)) {
77 *arg = list3(Qsignal, list2(Qquote, Qquit), Qnil);
79 } else if (SYMBOLP(data)
80 || (COMPILED_FUNCTIONP(data)
81 && XCOMPILED_FUNCTION(data)->flags.interactivep)
82 || (CONSP(data) && (EQ(XCAR(data), Qlambda))
83 && !NILP(Fassq(Qinteractive, Fcdr(Fcdr(data)))))) {
84 *fn = Qcall_interactively;
86 } else if (CONSP(data)) {
92 list2(Qquote, Qerror),
93 list2(Qquote, list2(build_translated_string
94 ("illegal callback"), data)));
99 * Add a value VAL associated with keyword KEY into PGUI_ITEM
100 * structure. If KEY is not a keyword, or is an unknown keyword, then
104 gui_item_add_keyval_pair(Lisp_Object gui_item,
105 Lisp_Object key, Lisp_Object val, Error_behavior errb)
107 Lisp_Gui_Item *pgui_item = XGUI_ITEM(gui_item);
111 syntax_error_2("Non-keyword in gui item", key, pgui_item->name);
113 if (EQ(key, Q_descriptor)) {
114 if (!EQ(pgui_item->name, val)) {
116 pgui_item->name = val;
120 else if (EQ (key, Q_##slot)) \
122 if (!EQ (pgui_item->slot, val)) \
125 pgui_item->slot = val; \
140 else if (EQ(key, Q_key_sequence)) ; /* ignored for FSF compatibility */
141 else if (EQ(key, Q_label)) ; /* ignored for 21.0 implement in 21.2 */
142 else if (EQ(key, Q_accelerator)) {
143 if (!EQ(pgui_item->accelerator, val)) {
145 if (SYMBOLP(val) || CHARP(val))
146 pgui_item->accelerator = val;
147 else if (ERRB_EQ(errb, ERROR_ME))
148 syntax_error("Bad keyboard accelerator", val);
150 } else if (ERRB_EQ(errb, ERROR_ME))
151 syntax_error_2("Unknown keyword in gui item", key,
156 void gui_item_init(Lisp_Object gui_item)
158 Lisp_Gui_Item *lp = XGUI_ITEM(gui_item);
162 lp->callback_ex = Qnil;
171 lp->accelerator = Qnil;
175 Lisp_Object allocate_gui_item(void)
178 alloc_lcrecord_type(Lisp_Gui_Item, &lrecord_gui_item);
182 XSETGUI_ITEM(val, lp);
190 * ITEM is a lisp vector, describing a menu item or a button. The
191 * function extracts the description of the item into the PGUI_ITEM
195 make_gui_item_from_keywords_internal(Lisp_Object item, Error_behavior errb)
197 int length, plist_p, start;
198 Lisp_Object *contents;
199 Lisp_Object gui_item = allocate_gui_item();
200 Lisp_Gui_Item *pgui_item = XGUI_ITEM(gui_item);
203 length = XVECTOR_LENGTH(item);
204 contents = XVECTOR_DATA(item);
208 ("GUI item descriptors must be at least 1 elts long", item);
210 /* length 1: [ "name" ]
211 length 2: [ "name" callback ]
212 length 3: [ "name" callback active-p ]
213 or [ "name" keyword value ]
214 length 4: [ "name" callback active-p suffix ]
215 or [ "name" callback keyword value ]
216 length 5+: [ "name" callback [ keyword value ]+ ]
217 or [ "name" [ keyword value ]+ ]
219 plist_p = (length > 2 && (KEYWORDP(contents[1])
220 || KEYWORDP(contents[2])));
222 pgui_item->name = contents[0];
223 if (length > 1 && !KEYWORDP(contents[1])) {
224 pgui_item->callback = contents[1];
229 if (!plist_p && length > 2)
232 pgui_item->active = contents[2];
234 pgui_item->suffix = contents[3];
239 if ((length - start) & 1)
241 ("GUI item descriptor has an odd number of keywords and values",
244 for (i = start; i < length;) {
245 Lisp_Object key = contents[i++];
246 Lisp_Object val = contents[i++];
247 gui_item_add_keyval_pair(gui_item, key, val, errb);
253 /* This will only work with descriptors in the new format. */
254 Lisp_Object widget_gui_parse_item_keywords(Lisp_Object item)
257 Lisp_Object *contents;
258 Lisp_Object gui_item = allocate_gui_item();
259 Lisp_Object desc = find_keyword_in_vector(item, Q_descriptor);
262 length = XVECTOR_LENGTH(item);
263 contents = XVECTOR_DATA(item);
265 if (!NILP(desc) && !STRINGP(desc) && !VECTORP(desc))
266 syntax_error("Invalid GUI item descriptor", item);
269 if (!SYMBOLP(contents[0]))
270 syntax_error("Invalid GUI item descriptor", item);
271 contents++; /* Ignore the leading symbol. */
275 for (i = 0; i < length;) {
276 Lisp_Object key = contents[i++];
277 Lisp_Object val = contents[i++];
278 gui_item_add_keyval_pair(gui_item, key, val, ERROR_ME_NOT);
284 /* Update a gui item from a partial descriptor. */
285 int update_gui_item_keywords(Lisp_Object gui_item, Lisp_Object item)
287 int i, length, retval = 0;
288 Lisp_Object *contents;
291 length = XVECTOR_LENGTH(item);
292 contents = XVECTOR_DATA(item);
295 if (!SYMBOLP(contents[0]))
296 syntax_error("Invalid GUI item descriptor", item);
297 contents++; /* Ignore the leading symbol. */
301 for (i = 0; i < length;) {
302 Lisp_Object key = contents[i++];
303 Lisp_Object val = contents[i++];
304 if (gui_item_add_keyval_pair(gui_item, key, val, ERROR_ME_NOT))
310 Lisp_Object gui_parse_item_keywords(Lisp_Object item)
312 return make_gui_item_from_keywords_internal(item, ERROR_ME);
315 Lisp_Object gui_parse_item_keywords_no_errors(Lisp_Object item)
317 return make_gui_item_from_keywords_internal(item, ERROR_ME_NOT);
320 /* convert a gui item into plist properties */
321 void gui_add_item_keywords_to_plist(Lisp_Object plist, Lisp_Object gui_item)
323 Lisp_Gui_Item *pgui_item = XGUI_ITEM(gui_item);
325 if (!NILP(pgui_item->callback))
326 Fplist_put(plist, Q_callback, pgui_item->callback);
327 if (!NILP(pgui_item->callback_ex))
328 Fplist_put(plist, Q_callback_ex, pgui_item->callback_ex);
329 if (!NILP(pgui_item->suffix))
330 Fplist_put(plist, Q_suffix, pgui_item->suffix);
331 if (!NILP(pgui_item->active))
332 Fplist_put(plist, Q_active, pgui_item->active);
333 if (!NILP(pgui_item->included))
334 Fplist_put(plist, Q_included, pgui_item->included);
335 if (!NILP(pgui_item->config))
336 Fplist_put(plist, Q_config, pgui_item->config);
337 if (!NILP(pgui_item->filter))
338 Fplist_put(plist, Q_filter, pgui_item->filter);
339 if (!NILP(pgui_item->style))
340 Fplist_put(plist, Q_style, pgui_item->style);
341 if (!NILP(pgui_item->selected))
342 Fplist_put(plist, Q_selected, pgui_item->selected);
343 if (!NILP(pgui_item->keys))
344 Fplist_put(plist, Q_keys, pgui_item->keys);
345 if (!NILP(pgui_item->accelerator))
346 Fplist_put(plist, Q_accelerator, pgui_item->accelerator);
347 if (!NILP(pgui_item->value))
348 Fplist_put(plist, Q_value, pgui_item->value);
352 * Decide whether a GUI item is active by evaluating its :active form
355 int gui_item_active_p(Lisp_Object gui_item)
357 /* This function can call lisp */
359 /* Shortcut to avoid evaluating Qt each time */
360 return (EQ(XGUI_ITEM(gui_item)->active, Qt)
361 || !NILP(Feval(XGUI_ITEM(gui_item)->active)));
364 /* set menu accelerator key to first underlined character in menu name */
365 Lisp_Object gui_item_accelerator(Lisp_Object gui_item)
367 Lisp_Gui_Item *pgui = XGUI_ITEM(gui_item);
369 if (!NILP(pgui->accelerator))
370 return pgui->accelerator;
373 return gui_name_accelerator(pgui->name);
376 Lisp_Object gui_name_accelerator(Lisp_Object nm)
378 Bufbyte *name = XSTRING_DATA(nm);
385 if (*name == '_' && *(name + 1)) {
386 Emchar accelerator = charptr_emchar(name + 1);
387 /* #### bogus current_buffer dependency */
390 (current_buffer, accelerator));
395 return make_char(DOWNCASE(current_buffer,
396 charptr_emchar(XSTRING_DATA(nm))));
400 * Decide whether a GUI item is selected by evaluating its :selected form
403 int gui_item_selected_p(Lisp_Object gui_item)
405 /* This function can call lisp */
407 /* Shortcut to avoid evaluating Qt each time */
408 return (EQ(XGUI_ITEM(gui_item)->selected, Qt)
409 || !NILP(Feval(XGUI_ITEM(gui_item)->selected)));
412 Lisp_Object gui_item_list_find_selected(Lisp_Object gui_item_list)
414 /* This function can GC. */
416 LIST_LOOP(rest, gui_item_list) {
417 if (gui_item_selected_p(XCAR(rest)))
420 return XCAR(gui_item_list);
424 * Decide whether a GUI item is included by evaluating its :included
425 * form if given, and testing its :config form against supplied CONFLIST
426 * configuration variable
428 int gui_item_included_p(Lisp_Object gui_item, Lisp_Object conflist)
430 /* This function can call lisp */
431 Lisp_Gui_Item *pgui_item = XGUI_ITEM(gui_item);
433 /* Evaluate :included first. Shortcut to avoid evaluating Qt each time */
434 if (!EQ(pgui_item->included, Qt)
435 && NILP(Feval(pgui_item->included)))
438 /* Do :config if conflist is given */
439 if (!NILP(conflist) && !NILP(pgui_item->config)
440 && NILP(Fmemq(pgui_item->config, conflist)))
446 static DOESNT_RETURN signal_too_long_error(Lisp_Object name)
448 syntax_error("GUI item produces too long displayable string", name);
451 #ifdef HAVE_WINDOW_SYSTEM
453 * Format "left flush" display portion of an item into BUF, guarded by
454 * maximum buffer size BUF_LEN. BUF_LEN does not count for terminating
455 * null character, so actual maximum size of buffer consumed is
456 * BUF_LEN + 1 bytes. If buffer is not big enough, then error is
458 * Return value is the offset to the terminating null character into the
462 gui_item_display_flush_left(Lisp_Object gui_item, char *buf, Bytecount buf_len)
464 /* This function can call lisp */
467 Lisp_Gui_Item *pgui_item = XGUI_ITEM(gui_item);
469 /* Copy item name first */
470 CHECK_STRING(pgui_item->name);
471 len = XSTRING_LENGTH(pgui_item->name);
473 signal_too_long_error(pgui_item->name);
474 memcpy(p, XSTRING_DATA(pgui_item->name), len);
477 /* Add space and suffix, if there is a suffix.
478 * If suffix is not string evaluate it */
479 if (!NILP(pgui_item->suffix)) {
480 Lisp_Object suffix = pgui_item->suffix;
481 /* Shortcut to avoid evaluating suffix each time */
482 if (!STRINGP(suffix)) {
483 suffix = Feval(suffix);
484 CHECK_STRING(suffix);
487 len = XSTRING_LENGTH(suffix);
488 if (p + len + 1 > buf + buf_len)
489 signal_too_long_error(pgui_item->name);
491 memcpy(p, XSTRING_DATA(suffix), len);
499 * Format "right flush" display portion of an item into BUF, guarded by
500 * maximum buffer size BUF_LEN. BUF_LEN does not count for terminating
501 * null character, so actual maximum size of buffer consumed is
502 * BUF_LEN + 1 bytes. If buffer is not big enough, then error is
504 * Return value is the offset to the terminating null character into the
508 gui_item_display_flush_right(Lisp_Object gui_item, char *buf, Bytecount buf_len)
510 Lisp_Gui_Item *pgui_item = XGUI_ITEM(gui_item);
515 if (!menubar_show_keybindings)
519 /* Try :keys first */
520 if (!NILP(pgui_item->keys)) {
521 CHECK_STRING(pgui_item->keys);
522 if (XSTRING_LENGTH(pgui_item->keys) + 1 > buf_len)
523 signal_too_long_error(pgui_item->name);
524 memcpy(buf, XSTRING_DATA(pgui_item->keys),
525 XSTRING_LENGTH(pgui_item->keys) + 1);
526 return XSTRING_LENGTH(pgui_item->keys);
529 /* See if we can derive keys out of callback symbol */
530 if (SYMBOLP(pgui_item->callback)) {
531 char buf2[1024]; /* #### */
534 where_is_to_char(pgui_item->callback, buf2);
537 signal_too_long_error(pgui_item->name);
542 /* No keys - no right flush display */
545 #endif /* HAVE_WINDOW_SYSTEM */
547 static Lisp_Object mark_gui_item(Lisp_Object obj)
549 Lisp_Gui_Item *p = XGUI_ITEM(obj);
551 mark_object(p->name);
552 mark_object(p->callback);
553 mark_object(p->callback_ex);
554 mark_object(p->config);
555 mark_object(p->suffix);
556 mark_object(p->active);
557 mark_object(p->included);
558 mark_object(p->config);
559 mark_object(p->filter);
560 mark_object(p->style);
561 mark_object(p->selected);
562 mark_object(p->keys);
563 mark_object(p->accelerator);
564 mark_object(p->value);
569 static unsigned long gui_item_hash(Lisp_Object obj, int depth)
571 Lisp_Gui_Item *p = XGUI_ITEM(obj);
573 return HASH2(HASH6(internal_hash(p->name, depth + 1),
574 internal_hash(p->callback, depth + 1),
575 internal_hash(p->callback_ex, depth + 1),
576 internal_hash(p->suffix, depth + 1),
577 internal_hash(p->active, depth + 1),
578 internal_hash(p->included, depth + 1)),
579 HASH6(internal_hash(p->config, depth + 1),
580 internal_hash(p->filter, depth + 1),
581 internal_hash(p->style, depth + 1),
582 internal_hash(p->selected, depth + 1),
583 internal_hash(p->keys, depth + 1),
584 internal_hash(p->value, depth + 1)));
587 int gui_item_id_hash(Lisp_Object hashtable, Lisp_Object gitem, int slot)
589 int hashid = gui_item_hash(gitem, 0);
590 int id = GUI_ITEM_ID_BITS(hashid, slot);
591 while (!NILP(Fgethash(make_int(id), hashtable, Qnil))) {
592 id = GUI_ITEM_ID_BITS(id + 1, slot);
597 int gui_item_equal_sans_selected(Lisp_Object obj1, Lisp_Object obj2, int depth)
599 Lisp_Gui_Item *p1 = XGUI_ITEM(obj1);
600 Lisp_Gui_Item *p2 = XGUI_ITEM(obj2);
602 if (!(internal_equal(p1->name, p2->name, depth + 1)
603 && internal_equal(p1->callback, p2->callback, depth + 1)
604 && internal_equal(p1->callback_ex, p2->callback_ex, depth + 1)
605 && EQ(p1->suffix, p2->suffix)
606 && EQ(p1->active, p2->active)
607 && EQ(p1->included, p2->included)
608 && EQ(p1->config, p2->config)
609 && EQ(p1->filter, p2->filter)
610 && EQ(p1->style, p2->style)
611 && EQ(p1->accelerator, p2->accelerator)
612 && EQ(p1->keys, p2->keys)
613 && EQ(p1->value, p2->value)))
618 static int gui_item_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
620 Lisp_Gui_Item *p1 = XGUI_ITEM(obj1);
621 Lisp_Gui_Item *p2 = XGUI_ITEM(obj2);
623 if (!(gui_item_equal_sans_selected(obj1, obj2, depth)
624 && EQ(p1->selected, p2->selected)))
630 print_gui_item(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
632 Lisp_Gui_Item *g = XGUI_ITEM(obj);
634 error("printing unreadable object #<gui-item 0x%x>",
636 write_fmt_string(printcharfun, "#<gui-item 0x%x>", g->header.uid);
639 Lisp_Object copy_gui_item(Lisp_Object gui_item)
641 Lisp_Object ret = allocate_gui_item();
642 Lisp_Gui_Item *lp, *g = XGUI_ITEM(gui_item);
646 lp->callback = g->callback;
647 lp->callback_ex = g->callback_ex;
648 lp->suffix = g->suffix;
649 lp->active = g->active;
650 lp->included = g->included;
651 lp->config = g->config;
652 lp->filter = g->filter;
653 lp->style = g->style;
654 lp->selected = g->selected;
656 lp->accelerator = g->accelerator;
657 lp->value = g->value;
662 Lisp_Object copy_gui_item_tree(Lisp_Object arg)
665 Lisp_Object rest = arg = Fcopy_sequence(arg);
666 while (CONSP(rest)) {
667 XCAR(rest) = copy_gui_item_tree(XCAR(rest));
671 } else if (GUI_ITEMP(arg))
672 return copy_gui_item(arg);
677 /* parse a glyph descriptor into a tree of gui items.
679 The gui_item slot of an image instance can be a single item or an
680 arbitrarily nested hierarchy of item lists. */
682 static Lisp_Object parse_gui_item_tree_item(Lisp_Object entry)
684 Lisp_Object ret = entry;
689 if (VECTORP(entry)) {
690 ret = gui_parse_item_keywords_no_errors(entry);
691 } else if (STRINGP(entry)) {
694 syntax_error("item must be a vector or a string", entry);
699 Lisp_Object parse_gui_item_tree_children(Lisp_Object list)
701 Lisp_Object rest, ret = Qnil, sub = Qnil;
702 struct gcpro gcpro1, gcpro2;
706 /* recursively add items to the tree view */
707 LIST_LOOP(rest, list) {
708 if (CONSP(XCAR(rest)))
709 sub = parse_gui_item_tree_list(XCAR(rest));
711 sub = parse_gui_item_tree_item(XCAR(rest));
713 ret = Fcons(sub, ret);
715 /* make the order the same as the items we have parsed */
716 RETURN_UNGCPRO(Fnreverse(ret));
719 static Lisp_Object parse_gui_item_tree_list(Lisp_Object list)
724 /* first one can never be a list */
725 ret = parse_gui_item_tree_item(XCAR(list));
727 ret = Fcons(ret, parse_gui_item_tree_children(XCDR(list)));
731 static void finalize_gui_item(void *header, int for_disksave)
735 DEFINE_LRECORD_IMPLEMENTATION("gui-item", gui_item,
736 mark_gui_item, print_gui_item,
737 finalize_gui_item, gui_item_equal,
738 gui_item_hash, 0, Lisp_Gui_Item);
740 void syms_of_gui(void)
742 INIT_LRECORD_IMPLEMENTATION(gui_item);
744 DEFSYMBOL(Qmenu_no_selection_hook);
747 DEFSUBR(Fpopup_up_p);
751 void vars_of_gui(void)
753 DEFVAR_LISP("menu-no-selection-hook", &Vmenu_no_selection_hook /*
754 Function or functions to call when a menu or dialog box is dismissed
755 without a selection having been made.
757 Vmenu_no_selection_hook = Qnil;