Mercurial > hg > xemacs-beta

comparison lisp/menubar.el @ 2545:9caf26dd924f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2005-02-03 05:03:36 by ben] behavior ws #2: menu-related changes menubar.c: New fun to compare menu itext as if the two were normalized. menubar.c: Rename; there are no external callers of this function. Remove unneeded BUFFER argument. Don't downcase. (This will be done in compare-menu-text.) Document that return value may be same string. easymenu.el, map-ynp.el: Use normalize-menu-text not normalize-menu-item-name. menubar-items.el, menubar.el: Move to menubar.el and rewrite for cleanliness. menubar-items.el: Use menu-split-long-menu-and-sort. menubar-items.el, menubar.el: Move to menubar.el. menubar.el: New funs. menubar.el: Split up find-menu-item w/find-menu-item-1, since PARENT is not an external item. Rewrite to use compare-menu-text. menubar.el: Don't normalize items as find-menu-item does not need it. menubar-items.el: Delete old Behavior menu defn, replaced by behavior-menu-filter. Planning to [[Delete many menus from Tools menu -- they have been integrated as part of the behavior system.]] Currently the new Tools menu (very short, just a call to the behavior-menu-filter) is commented out, and the old Toold menu defn remains. Once the new packages are in place (c. 1 or 2 weeks), I'll make the switchover. Use menu-split-long-menu-and-sort.
author ben
date Thu, 03 Feb 2005 05:03:45 +0000
parents a307f9a2021d
children 979c4c930bb5
comparison
equal deleted inserted replaced
2544:b4a8cd0dd8df 2545:9caf26dd924f
1 ;;; menubar.el --- Menubar support for XEmacs 1 ;;; menubar.el --- Menubar support for XEmacs
2 2
3 ;; Copyright (C) 1991-4, 1997-1998 Free Software Foundation, Inc. 3 ;; Copyright (C) 1991-4, 1997-1998 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1995, 1996 Ben Wing. 5 ;; Copyright (C) 1995, 1996, 2003 Ben Wing.
6 6
7 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: internal, extensions, dumped 8 ;; Keywords: internal, extensions, dumped
9 9
10 ;; This file is part of XEmacs. 10 ;; This file is part of XEmacs.
161 ;; (t (signal 'error (list "unrecognized menu descriptor" menuitem)))) 161 ;; (t (signal 'error (list "unrecognized menu descriptor" menuitem))))
162 (t (message "unrecognized menu descriptor %s" (prin1-to-string menuitem)))) 162 (t (message "unrecognized menu descriptor %s" (prin1-to-string menuitem))))
163 (setq menu (cdr menu))))) 163 (setq menu (cdr menu)))))
164 164
165 165
166 ;;; menu manipulation functions 166 ;;; basic menu manipulation functions
167 167
168 (defun find-menu-item (menubar item-path-list &optional parent) 168 (defun menu-item-text (item &optional normalize)
169 "Search MENUBAR for item given by ITEM-PATH-LIST starting from PARENT. 169 "Return the text that is displayed for a menu item.
170 If ITEM is a string (unselectable text), it is returned; otherwise,
171 the first element of the cons or vector is returned.
172 If NORMALIZE is non-nil, pass the text through `normalize-menu-text'
173 before being returned, to remove accelerator specs and convert %% to %."
174 (let ((val (if (stringp item) item (elt item 0))))
175 (if normalize (normalize-menu-text val) val)))
176
177 (defun find-menu-item (menubar item-path-list)
178 "Search MENUBAR for item given by ITEM-PATH-LIST.
170 Returns (ITEM . PARENT), where PARENT is the immediate parent of 179 Returns (ITEM . PARENT), where PARENT is the immediate parent of
171 the item found. 180 the item found.
172 If the item does not exist, the car of the returned value is nil. 181 If the item does not exist, the car of the returned value is nil.
173 If some menu in the ITEM-PATH-LIST does not exist, an error is signalled." 182 If some menu in the ITEM-PATH-LIST does not exist, an error is signalled."
183 (find-menu-item-1 menubar item-path-list))
184
185 (defun find-menu-item-1 (menubar item-path-list &optional parent)
174 (check-argument-type 'listp item-path-list) 186 (check-argument-type 'listp item-path-list)
175 (unless parent
176 (setq item-path-list (mapcar 'normalize-menu-item-name item-path-list)))
177 (if (not (consp menubar)) 187 (if (not (consp menubar))
178 nil 188 nil
179 (let ((rest menubar) 189 (let ((rest menubar)
180 result) 190 result)
181 (when (stringp (car rest)) 191 (when (stringp (car rest))
182 (setq rest (cdr rest))) 192 (setq rest (cdr rest)))
183 (while (keywordp (car rest)) 193 (while (keywordp (car rest))
184 (setq rest (cddr rest))) 194 (setq rest (cddr rest)))
185 (while rest 195 (while rest
186 (if (and (car rest) 196 (if (and (car rest)
187 (equal (car item-path-list) 197 (stringp (car item-path-list))
188 (normalize-menu-item-name 198 (= 0 (compare-menu-text (car item-path-list)
189 (cond ((vectorp (car rest)) 199 (menu-item-text (car rest)))))
190 (aref (car rest) 0))
191 ((stringp (car rest))
192 (car rest))
193 (t
194 (caar rest))))))
195 (setq result (car rest) 200 (setq result (car rest)
196 rest nil) 201 rest nil)
197 (setq rest (cdr rest)))) 202 (setq rest (cdr rest))))
198 (if (cdr item-path-list) 203 (if (cdr item-path-list)
199 (cond ((consp result) 204 (cond ((consp result)
206 (cons result parent))))) 211 (cons result parent)))))
207 212
208 (defun add-menu-item-1 (leaf-p menu-path new-item before in-menu) 213 (defun add-menu-item-1 (leaf-p menu-path new-item before in-menu)
209 ;; This code looks like it could be cleaned up some more 214 ;; This code looks like it could be cleaned up some more
210 ;; Do we really need 6 calls to find-menu-item? 215 ;; Do we really need 6 calls to find-menu-item?
211 (when before (setq before (normalize-menu-item-name before)))
212 (let* ((item-name 216 (let* ((item-name
213 (cond ((vectorp new-item) (aref new-item 0)) 217 (cond ((vectorp new-item) (aref new-item 0))
214 ((consp new-item) (car new-item)) 218 ((consp new-item) (car new-item))
215 (t nil))) 219 (t nil)))
216 (menubar (or in-menu current-menubar)) 220 (menubar (or in-menu current-menubar))
462 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the 466 under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the
463 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." 467 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
464 (enable-menu-item-1 path t nil)) 468 (enable-menu-item-1 path t nil))
465 469
466 470
471 ;;; functions for manipulating whole menus -- adding accelerators, sorting,
472 ;;; splitting long menus, etc.
473
474 (defun submenu-generate-accelerator-spec (list &optional omit-chars-list)
475 "Add auto-generated accelerator specifications to a submenu.
476 This can be used to add accelerators to the return value of a menu filter
477 function. It correctly ignores unselectable items. It will destructively
478 modify the list passed to it. If an item already has an auto-generated
479 accelerator spec, this will be removed before the new one is added, making
480 this function idempotent.
481
482 If OMIT-CHARS-LIST is given, it should be a list of lowercase characters,
483 which will not be used as accelerators."
484 (let ((n 0))
485 (dolist (item list list)
486 (cond
487 ((or (vectorp item) (consp item))
488 (incf n)
489 (setf (elt item 0)
490 (concat
491 (menu-item-generate-accelerator-spec n omit-chars-list)
492 (menu-item-strip-accelerator-spec (elt item 0)))))))))
493
494 (defun menu-item-strip-accelerator-spec (item)
495 "Strip an auto-generated accelerator spec off of ITEM.
496 ITEM should be a string. This removes specs added by
497 `menu-item-generate-accelerator-spec' and `submenu-generate-accelerator-spec'."
498 (if (string-match "%_. " item)
499 (substring item 4)
500 item))
501
502 (defun menu-item-generate-accelerator-spec (n &optional omit-chars-list)
503 "Return an accelerator specification for use with auto-generated menus.
504 This should be concat'd onto the beginning of each menu line. The spec
505 allows the Nth line to be selected by the number N. '0' is used for the
506 10th line, and 'a' through 'z' are used for the following 26 lines.
507
508 If OMIT-CHARS-LIST is given, it should be a list of lowercase characters,
509 which will not be used as accelerators."
510 (cond ((< n 10) (concat "%_" (int-to-string n) " "))
511 ((= n 10) "%_0 ")
512 ((<= n 36)
513 (setq n (- n 10))
514 (let ((m 0))
515 (while (> n 0)
516 (setq m (1+ m))
517 (while (memq (int-to-char (+ m (- (char-to-int ?a) 1)))
518 omit-chars-list)
519 (setq m (1+ m)))
520 (setq n (1- n)))
521 (if (<= m 26)
522 (concat
523 "%_"
524 (char-to-string (int-to-char (+ m (- (char-to-int ?a) 1))))
525 " ")
526 "")))
527 (t "")))
528
529 (defcustom menu-max-items 25
530 "*Maximum number of items in generated menus.
531 If number of entries in such a menu is larger than this value, split menu
532 into submenus of nearly equal length (see `menu-submenu-max-items'). If
533 nil, never split menu into submenus."
534 :group 'menu
535 :type '(choice (const :tag "no submenus" nil)
536 (integer)))
537
538 (defcustom menu-submenu-max-items 20
539 "*Maximum number of items in submenus when splitting menus.
540 We split large menus into submenus of this many items, and then balance
541 them out as much as possible (otherwise the last submenu may have very few
542 items)."
543 :group 'menu
544 :type 'integer)
545
546 (defcustom menu-submenu-name-format "%-12.12s ... %.12s"
547 "*Format specification of the submenu name when splitting menus.
548 Used by `menu-split-long-menu' if the number of entries in a menu is
549 larger than `menu-menu-max-items'.
550 This string should contain one %s for the name of the first entry and
551 one %s for the name of the last entry in the submenu.
552 If the value is a function, it should return the submenu name. The
553 function is be called with two arguments, the names of the first and
554 the last entry in the menu."
555 :group 'menu
556 :type '(choice (string :tag "Format string")
557 (function)))
558
559 (defun menu-split-long-menu-and-sort (menu)
560 "Sort MENU, split according to `menu-max-items' and add accelerator specs.
561 This is useful for menus generated by filter functions, to make them look
562 nice. This is equivalent to
563
564 \(menu-split-long-menu (menu-sort-menu menu))
565
566 and you can call those functions individually if necessary.
567 You can also call `submenu-generate-accelerator-spec' yourself to add
568 accelerator specs -- this works even if the specs have already been added."
569 (menu-split-long-menu (menu-sort-menu menu)))
570
571 (defun menu-split-long-menu (menu)
572 "Split MENU according to `menu-max-items' and add accelerator specs.
573 If MENU already has accelerator specs, they will be removed and new ones
574 generated. You should normally use `menu-split-long-menu-and-sort' instead.
575 The menu should already be sorted to get meaningful results when it is
576 split, since the outer menus are of the format `FROM ... TO'."
577 (let ((len (length menu)))
578 (if (or (null menu-max-items)
579 (<= len menu-max-items))
580 (submenu-generate-accelerator-spec menu)
581 (let* ((outer (/ (+ len (1- menu-submenu-max-items))
582 menu-submenu-max-items))
583 (inner (/ (+ len (1- outer)) outer))
584 (result nil))
585 (while menu
586 (let ((sub nil)
587 (from (car menu)))
588 (dotimes (foo (min inner len))
589 (setq sub (cons (car menu) sub)
590 menu (cdr menu)))
591 (setq len (- len inner))
592 (let* ((to (car sub))
593 (ftext (menu-item-strip-accelerator-spec
594 (menu-item-text from)))
595 (ttext (menu-item-strip-accelerator-spec
596 (menu-item-text to))))
597 (setq sub (nreverse sub))
598 (setq result
599 (cons (cons (if (stringp menu-submenu-name-format)
600 (format menu-submenu-name-format
601 ftext ttext)
602 (funcall menu-submenu-name-format
603 ftext ttext))
604 (submenu-generate-accelerator-spec sub))
605 result)))))
606 (submenu-generate-accelerator-spec (nreverse result))))))
607
608 (defun menu-sort-menu (menu)
609 "Sort MENU alphabetically.
610 You should normally use `menu-split-long-menu-and-sort' instead."
611 (sort menu
612 #'(lambda (a b) (< (compare-menu-text
613 (menu-item-text a) (menu-item-text b))
614 0))))
615
467 616
468 ;;;;;;; popup menus 617 ;;;;;;; popup menus
469 618
470 (defvar global-popup-menu nil 619 (defvar global-popup-menu nil
471 "The global popup menu. This is present in all modes. 620 "The global popup menu. This is present in all modes.