# HG changeset patch # User Richard M. Stallman # Date 885933837 0 # Node ID 0c51c56d0a4f5dc36bb30b1f38628acb9eaab1c0 # Parent 7fd6ce99f3894c29dd799df5edbc6d9a4a4d54af easy-menu-define): Use ` and , read-macros instead of (` and (,. Implement :filter. Doc fix. (easy-menu-do-define): Call `easy-menu-create-menu' instead of `easy-menu-create-keymaps'. (easy-menu-create-keymaps): Replaced by `easy-menu-create-menu'. (easy-menu-create-menu): New public function. Replaces `easy-menu-create-keymaps', but with large changes. (easy-menu-button-prefix): New constant. (easy-menu-do-add-item, easy-menu-make-symbol): New functions. (easy-menu-update-button): Doc fix. (easy-menu-change): New optional argument BEFORE. Now just a call to `easy-menu-add-item'. (easy-menu-add-item, easy-menu-item-present-p) (easy-menu-remove-item): New public functions. (easy-menu-get-map, easy-menu-is-button-p, easy-menu-have-button-p) (easy-menu-real-binding, easy-menu-change-prefix, easy-menu-filter): New functions. diff -r 7fd6ce99f389 -r 0c51c56d0a4f lisp/emacs-lisp/easymenu.el --- a/lisp/emacs-lisp/easymenu.el Tue Jan 27 20:07:30 1998 +0000 +++ b/lisp/emacs-lisp/easymenu.el Tue Jan 27 20:43:57 1998 +0000 @@ -1,6 +1,6 @@ ;;; easymenu.el --- support the easymenu interface for defining a menu. -;; Copyright (C) 1994, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1996, 1998 Free Software Foundation, Inc. ;; Keywords: emulations ;; Author: rms @@ -37,6 +37,11 @@ and as its function definition. DOC is used as the doc string for SYMBOL. The first element of MENU must be a string. It is the menu bar item name. +It may be followed by the keyword argument pair + :filter FUNCTION +FUNCTION is a function with one argument, the menu. It returns the actual +menu displayed. + The rest of the elements are menu items. A menu item is usually a vector of three elements: [NAME CALLBACK ENABLE] @@ -53,7 +58,7 @@ [ NAME CALLBACK [ KEYWORD ARG ] ... ] -Where KEYWORD is one of the symbol defined below. +Where KEYWORD is one of the symbols defined below. :keys KEYS @@ -92,11 +97,12 @@ A menu item can be a list. It is treated as a submenu. The first element should be the submenu name. That's used as the -menu item in the top-level menu. The cdr of the submenu list -is a list of menu items, as above." - (` (progn - (defvar (, symbol) nil (, doc)) - (easy-menu-do-define (quote (, symbol)) (, maps) (, doc) (, menu))))) +menu item name in the top-level menu. It may be followed by the :filter +FUNCTION keyword argument pair. The rest of the submenu list are menu items, +as above." + `(progn + (defvar ,symbol nil ,doc) + (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) ;;;###autoload (defun easy-menu-do-define (symbol maps doc menu) @@ -104,7 +110,7 @@ ;; `easy-menu-define' in order to make byte compiled files ;; compatible. Therefore everything interesting is done in this ;; function. - (set symbol (easy-menu-create-keymaps (car menu) (cdr menu))) + (set symbol (easy-menu-create-menu (car menu) (cdr menu))) (fset symbol (` (lambda (event) (, doc) (interactive "@e") (x-popup-menu event (, symbol))))) (mapcar (function (lambda (map) @@ -112,110 +118,169 @@ (cons (car menu) (symbol-value symbol))))) (if (keymapp maps) (list maps) maps))) -(defvar easy-menu-item-count 0) +(defun easy-menu-filter-return (menu) + "Convert MENU to the right thing to return from a menu filter. +MENU is a menu as computed by `easy-menu-define' or `easy-menu-create-menu' or +a symbol whose value is such a menu. +In Emacs a menu filter must return a menu (a keymap), in XEmacs a filter must +return a menu items list (without menu name and keywords). This function +returns the right thing in the two cases." + (easy-menu-get-map menu nil)) ; Get past indirections. -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. ;;;###autoload -(defun easy-menu-create-keymaps (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name)) old-items have-buttons) +(defun easy-menu-create-menu (menu-name menu-items) + "Create a menu called MENU-NAME with items described in MENU-ITEMS. +MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items +possibly preceded by keyword pairs as described in `easy-menu-define'." + (let ((menu (make-sparse-keymap menu-name)) + keyword filter have-buttons) + ;; Look for keywords. + (while (and menu-items (cdr menu-items) + (symbolp (setq keyword (car menu-items))) + (= ?: (aref (symbol-name keyword) 0))) + (if (eq keyword ':filter) (setq filter (cadr menu-items))) + (setq menu-items (cddr menu-items))) ;; Process items in reverse order, ;; since the define-key loop reverses them again. (setq menu-items (reverse menu-items)) (while menu-items - (let* ((item (car menu-items)) - (callback (if (vectorp item) (aref item 1))) - (not-button t) - command enabler item-string name) - (cond ((stringp item) - (setq command nil) - (setq item-string (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (easy-menu-create-keymaps (car item) (cdr item))) - (setq name (setq item-string (car item)))) - ((vectorp item) - (setq command (make-symbol (format "menu-function-%d" - easy-menu-item-count))) - (setq easy-menu-item-count (1+ easy-menu-item-count)) - (setq name (setq item-string (aref item 0))) - (let ((keyword (aref item 2))) - (if (and (symbolp keyword) - (= ?: (aref (symbol-name keyword) 0))) - (let ((count 2) - style selected active keys active-specified - arg) - (while (> (length item) count) - (setq keyword (aref item count)) - (setq arg (aref item (1+ count))) - (setq count (+ 2 count)) - (cond ((eq keyword ':keys) - (setq keys arg)) - ((eq keyword ':active) - (setq active (or arg ''nil) - active-specified t)) - ((eq keyword ':suffix) - (setq item-string - (concat item-string " " arg))) - ((eq keyword ':style) - (setq style arg)) - ((eq keyword ':selected) - (setq selected arg)))) - (if keys - (setq item-string - (concat item-string " (" keys ")"))) - (if (and selected - (or (eq style 'radio) (eq style 'toggle))) - ;; Simulate checkboxes and radio buttons. - (progn - (setq item-string - (concat - (if (eval selected) - (if (eq style 'radio) "(*) " "[X] ") - (if (eq style 'radio) "( ) " "[ ] ")) - item-string)) - (put command 'menu-enable - (list 'easy-menu-update-button - item-string - (if (eq style 'radio) ?* ?X) - selected - (or active t))) - (setq not-button nil - active nil - have-buttons t) - (while old-items ; Fix items aleady defined. - (setcar (car old-items) - (concat " " (car (car old-items)))) - (setq old-items (cdr old-items))))) - (if active-specified (put command 'menu-enable active))) - ;; If the third element is nil, - ;; make this command always disabled. - (put command 'menu-enable (or keyword ''nil)))) - (if (symbolp callback) - (fset command callback) - (fset command (list 'lambda () '(interactive) callback))) - (put command 'menu-alias t))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil item-string) (cdr menu))) - (if (and not-button have-buttons) - (setq item-string (concat " " item-string))) - (setq command (cons item-string command)) - (if (not have-buttons) ; Save all items so that we can fix - (setq old-items (cons command old-items))) ; if we have buttons. - (when name - (let ((key (vector (intern name)))) - (if (lookup-key menu key) - (setq key (vector (intern (concat name "*"))))) - (define-key menu key command))))) + (setq have-buttons + (easy-menu-do-add-item menu (car menu-items) have-buttons)) (setq menu-items (cdr menu-items))) + (when filter + (setq menu (easy-menu-make-symbol menu nil)) + (put menu 'menu-enable + `(easy-menu-filter (quote ,menu) (quote ,filter)))) menu)) + +;; Button prefixes. +(defvar easy-menu-button-prefix + '((radio ?* . "( ) ") (toggle ?X . "[ ] "))) + +(defun easy-menu-do-add-item (menu item have-buttons &optional prev top) + ;; Parse an item description and add the item to a keymap. This is + ;; the function that is used for item definition by the other easy-menu + ;; functions. + ;; MENU is a sparse keymap. + ;; ITEM defines an item as in `easy-menu-define'. + ;; HAVE-BUTTONS is a string or nil. If not nil, use as item prefix for + ;; items that are not toggle or radio buttons to compensate for the + ;; button prefix. + ;; PREV is nil or a tail in MENU. If PREV is not nil put item after + ;; PREV in MENU, otherwise put it first in MENU. + ;; If TOP is true, this is an item in the menu bar itself so + ;; don't use prefix. In this case HAVE-BUTTONS will be nil. + (let (command name item-string is-button) + (cond + ((stringp item) + (setq item + (if (string-match ; If an XEmacs separator + "^\\(-+\\|\ +--:\\(\\(no\\|\\(sing\\|doub\\)le\\(Dashed\\)?\\)Line\\|\ +shadow\\(Double\\)?Etched\\(In\\|Out\\)\\(Dash\\)?\\)\\)$" + item) "" ; use a single line separator. + (concat have-buttons item))) + ;; Handle inactive strings specially, + ;; allow any number of identical ones. + (cond + (prev (setq menu prev)) + ((and (consp (cdr menu)) (stringp (cadr menu))) (setq menu (cdr menu)))) + (setcdr menu (cons (list nil item) (cdr menu)))) + ((consp item) + (setq name (setq item-string (car item))) + (setq command (if (keymapp (setq item (cdr item))) item + (easy-menu-create-menu name item)))) + ((vectorp item) + (setq name (setq item-string (aref item 0))) + (setq command (easy-menu-make-symbol (aref item 1) t)) + (let ((active (aref item 2)) + (count 2) + style selected) + (if (and (symbolp active) (= ?: (aref (symbol-name active) 0))) + (let ((count 2) keyword arg suffix keys) + (setq active nil) + (while (> (length item) count) + (setq keyword (aref item count)) + (setq arg (aref item (1+ count))) + (setq count (+ 2 count)) + (cond + ((eq keyword ':keys) (setq keys arg)) + ((eq keyword ':active) (setq active arg)) + ((eq keyword ':suffix) (setq suffix arg)) + ((eq keyword ':style) (setq style arg)) + ((eq keyword ':selected) (setq selected arg)))) + (if suffix (setq item-string (concat item-string " " suffix))) + (if keys + (setq item-string (concat item-string " (" keys ")"))) + (when (and selected + (setq style (assq style easy-menu-button-prefix))) + ;; Simulate checkboxes and radio buttons. + (setq item-string (concat (cddr style) item-string)) + (put command 'menu-enable + `(easy-menu-update-button ,item-string + ,(cadr style) + ,selected + ,(or active t))) + (setq is-button t) + (setq active nil) ; Already taken care of active. + (when (not (or have-buttons top)) + (setq have-buttons " ") + ;; Add prefix to menu items defined so far. + (easy-menu-change-prefix menu t))))) + (if active (put command 'menu-enable active))))) + (when name + (and (not is-button) have-buttons + (setq item-string (concat have-buttons item-string))) + (setq item (cons item-string command)) + (setq name (vector (intern name))) + (if prev (define-key-after menu name item (vector (caar prev))) + (define-key menu name item))) + have-buttons)) + +(defvar easy-menu-item-count 0) + +(defun easy-menu-make-symbol (callback call) + ;; Return a unique symbol with CALLBACK as function value. + ;; If CALL is false then this is a keymap, not a function. + ;; Else if CALLBACK is a symbol, avoid the indirection when looking for + ;; key-bindings in menu. + ;; Else make a lambda expression of CALLBACK. + (let ((command + (make-symbol (format "menu-function-%d" easy-menu-item-count)))) + (setq easy-menu-item-count (1+ easy-menu-item-count)) + (fset command + (cond + ((not call) callback) + ((symbolp callback) + ;; Try find key-bindings for callback instead of for command + (put command 'menu-alias t) ; when displaying menu. + callback) + (t `(lambda () (interactive) ,callback)))) + command)) + +(defun easy-menu-filter (name filter) + "Used as menu-enable property to filter menus. +A call to this function is used as the menu-enable property for a menu with +a filter function. +NAME is a symbol with a keymap as function value. Call the function FILTER +with this keymap as argument. FILTER must return a keymap which becomes the +new function value for NAME. Use `easy-menu-filter-return' to return the +correct value in a way portable to XEmacs. If the new keymap is `eq' the old, +then the menu is not updated." + (let* ((old (symbol-function name)) + (new (funcall filter old))) + (or (eq old new) ; No change + (and (fset name new) + ;; Make sure the menu gets updated by returning a + ;; different value than last time to cheat the cache. + (random))))) + (defun easy-menu-update-button (item ch selected active) "Used as menu-enable property to update buttons. A call to this function is used as the menu-enable property for buttons. -ITEM is the item-string into wich CH or ` ' is inserted depending on if -SELECTED is true or not. The menu entry in enabled iff ACTIVE is true." +ITEM is the item-string into which CH or ` ' is inserted depending on if +SELECTED is true or not. The menu entry in enabled iff ACTIVE is true." (let ((new (if selected ch ? )) (old (aref item 1))) (if (eq new old) @@ -228,24 +293,153 @@ (and active (random))))) -(defun easy-menu-change (path name items) +(defun easy-menu-change (path name items &optional before) "Change menu found at PATH as item NAME to contain ITEMS. PATH is a list of strings for locating the menu containing NAME in the menu bar. ITEMS is a list of menu items, as in `easy-menu-define'. These items entirely replace the previous items in that map. +If NAME is not present in the menu located by PATH, then add item NAME to +that menu. If the optional argument BEFORE is present add NAME in menu +just before BEFORE, otherwise add at end of menu. -Call this from `menu-bar-update-hook' to implement dynamic menus." - (let ((map (key-binding (apply 'vector - 'menu-bar - (mapcar 'intern (append path (list name))))))) - (if (keymapp map) - (setcdr map (cdr (easy-menu-create-keymaps name items))) - (error "Malformed menu in `easy-menu-change'")))) +Either call this from `menu-bar-update-hook' or use a menu filter, +to implement dynamic menus." + (easy-menu-add-item nil path (cons name items) before)) +;; XEmacs needs the following two functions to add and remove menus. +;; In Emacs this is done automatically when switching keymaps, so +;; here these functions are noops. (defun easy-menu-remove (menu)) (defun easy-menu-add (menu &optional map)) +(defun easy-menu-add-item (menu path item &optional before) + "At the end of the submenu of MENU with path PATH add ITEM. +If ITEM is already present in this submenu, then this item will be changed. +otherwise ITEM will be added at the end of the submenu, unless the optional +argument BEFORE is present, in which case ITEM will instead be added +before the item named BEFORE. +MENU is either a symbol, which have earlier been used as the first +argument in a call to `easy-menu-define', or the value of such a symbol +i.e. a menu, or nil which stands for the menu-bar itself. +PATH is a list of strings for locating the submenu where ITEM is to be +added. If PATH is nil, MENU itself is used. Otherwise, the first +element should be the name of a submenu directly under MENU. This +submenu is then traversed recursively with the remaining elements of PATH. +ITEM is either defined as in `easy-menu-define' or a menu defined earlier +by `easy-menu-define' or `easy-menu-create-menu'." + (let ((top (not (or menu path))) + tmp prev next) + (setq menu (easy-menu-get-map menu path)) + (or (lookup-key menu (vector (intern (elt item 0)))) + (and menu (keymapp (cdr menu))) + (setq tmp (cdr menu))) + (while (and tmp (not (keymapp tmp)) + (not (and (consp (car tmp)) (symbolp (caar tmp))))) + (setq tmp (cdr tmp))) + (and before (setq before (intern before))) + (if (or (null tmp) (keymapp tmp) (eq (setq prev (caar tmp)) before)) + (setq prev nil) + (while (and tmp (not (keymapp tmp)) + (not (and (consp (car tmp)) + (eq (caar (setq next tmp)) before)))) + (if next (setq prev next)) + (setq next nil) + (setq tmp (cdr tmp)))) + (when (or (keymapp item) + (and (symbolp item) (keymapp (symbol-value item)))) + ;; Item is a keymap, find the prompt string and use as item name. + (setq next (easy-menu-get-map item nil)) + (if (not (keymapp item)) (setq item next)) + (setq tmp nil) ; No item name yet. + (while (and (null tmp) (consp (setq next (cdr next))) + (not (keymapp next))) + (if (stringp (car next)) (setq tmp (car next)) ; Got a name. + (setq next (cdr next)))) + (setq item (cons tmp item))) + (easy-menu-do-add-item menu item + (and (not top) (easy-menu-have-button menu) " ") + prev top))) + +(defun easy-menu-item-present-p (menu path name) + "In submenu of MENU with path PATH, return true iff item NAME is present. +MENU and PATH are defined as in `easy-menu-add-item'. +NAME should be a string, the name of the element to be looked for." + (lookup-key (easy-menu-get-map menu path) (vector (intern name)))) + +(defun easy-menu-remove-item (menu path name) + "From submenu of MENU with path PATH remove item NAME. +MENU and PATH are defined as in `easy-menu-add-item'. +NAME should be a string, the name of the element to be removed." + (let ((item (vector (intern name))) + (top (not (or menu path))) + tmp) + (setq menu (easy-menu-get-map menu path)) + (when (setq tmp (lookup-key menu item)) + (define-key menu item nil) + (and (not top) + (easy-menu-is-button tmp) ; Removed item was a button and + (not (easy-menu-have-button menu)) ; no buttons left then + ;; remove prefix from items in menu + (easy-menu-change-prefix menu nil))))) + +(defun easy-menu-get-map (menu path) + ;; Return a sparse keymap in which to add or remove an item. + ;; MENU and PATH are as defined in `easy-menu-remove-item'. + (if (null menu) + (setq menu (key-binding (vconcat '(menu-bar) (mapcar 'intern path)))) + (if (and (symbolp menu) (not (keymapp menu))) + (setq menu (symbol-value menu))) + (if path (setq menu (lookup-key menu (vconcat (mapcar 'intern path)))))) + (while (and (symbolp menu) (keymapp menu)) + (setq menu (symbol-function menu))) + (or (keymapp menu) (error "Malformed menu in easy-menu: (%s)" menu)) + menu) + +(defun easy-menu-is-button (val) + ;; VAL is a real menu binding. Return true iff it is a toggle or + ;; radio button. + (and (symbolp val) + (consp (setq val (get val 'menu-enable))) + (eq (car val) 'easy-menu-update-button))) + +(defun easy-menu-have-button (map) + ;; MAP is a sparse keymap. Return true iff there is any toggle or radio + ;; button in MAP. + (let ((have nil) tmp) + (while (and (consp map) (not have)) + (and (consp (setq tmp (car map))) + (consp (setq tmp (cdr tmp))) + (stringp (car tmp)) + (setq have (easy-menu-is-button (easy-menu-real-binding tmp)))) + (setq map (cdr map))) + have)) + +(defun easy-menu-real-binding (val) + ;; Val is a menu keymap binding. Skip item string. + ;; Also skip a possible help string and/or key-binding cache. + (if (and (consp (setq val (cdr val))) (stringp (car val))) + (setq val (cdr val))) ; Skip help string. + (if (and (consp val) (consp (car val)) + (or (null (caar val)) (vectorp (caar val)))) + (setq val (cdr val))) ; Skip key-binding cache. + val) + +(defun easy-menu-change-prefix (map add) + ;; MAP is a sparse keymap. + ;; If ADD is true add a button compensating prefix to each menu item in MAP. + ;; Else remove prefix instead. + (let (tmp val) + (while (consp map) + (when (and (consp (setq tmp (car map))) + (consp (setq tmp (cdr tmp))) + (stringp (car tmp))) + (cond + (add (setcar tmp (concat " " (car tmp)))) + ((string-match "$ " (car tmp)) + (setcar tmp (substring (car tmp) (match-end 0)))))) + (setq map (cdr map))))) + (provide 'easymenu) ;;; easymenu.el ends here