Use new menu item format. Don't simulate button prefix.
(easy-menu-create-menu): Understand also keywords :active, :label and :visible. Don't worry about button prefix. (easy-menu-button-prefix): Modified value. (easy-menu-do-add-item): Extensive changes to use new menu item format. (easy-menu-define-key, easy-menu-always-true): New functions. (easy-menu-make-symbol): Don't use indirection for symbols. Property `menu-alias' not set. (easy-menu-filter, easy-menu-update-button): Deleted. (easy-menu-add-item): Don't worry about button prefix. (easy-menu-remove-item): Don't worry about button prefix. Use `easy-menu-define-key'. (easy-menu-is-button, easy-menu-have-button): Deleted. (easy-menu-real-binding, easy-menu-change-prefix): Deleted.
This commit is contained in:
Richard M. Stallman
parent
ee59c65fd0
commit
c78fb6a6fb
1 changed files with 150 additions and 204 deletions
|
|
@ -133,186 +133,190 @@ returns the right thing in the two cases."
|
|||
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)
|
||||
prop keyword arg label enable filter visible)
|
||||
;; 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)))
|
||||
(while menu-items
|
||||
(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))
|
||||
(put menu 'menu-enable
|
||||
`(easy-menu-filter (quote ,menu) (quote ,filter))))
|
||||
menu))
|
||||
(setq arg (cadr menu-items))
|
||||
(setq menu-items (cddr menu-items))
|
||||
(cond
|
||||
((eq keyword ':filter) (setq filter arg))
|
||||
((eq keyword ':active) (setq enable (or arg ''nil)))
|
||||
((eq keyword ':label) (setq label arg))
|
||||
((eq keyword ':visible) (setq visible (or arg ''nil)))))
|
||||
(if (equal visible ''nil) nil ; Invisible menu entry, return nil.
|
||||
(if (and visible (not (easy-menu-always-true visible)))
|
||||
(setq prop (cons :visible (cons visible prop))))
|
||||
(if (and enable (not (easy-menu-always-true enable)))
|
||||
(setq prop (cons :enable (cons enable prop))))
|
||||
(if filter (setq prop (cons :filter (cons filter prop))))
|
||||
(if label (setq prop (cons nil (cons label prop))))
|
||||
(while menu-items
|
||||
(easy-menu-do-add-item menu (car menu-items))
|
||||
(setq menu-items (cdr menu-items)))
|
||||
(when prop
|
||||
(setq menu (easy-menu-make-symbol menu))
|
||||
(put menu 'menu-prop prop))
|
||||
menu)))
|
||||
|
||||
|
||||
;; Button prefixes.
|
||||
(defvar easy-menu-button-prefix
|
||||
'((radio ?* . "( ) ") (toggle ?X . "[ ] ")))
|
||||
'((radio . :radio) (toggle . :toggle)))
|
||||
|
||||
(defun easy-menu-do-add-item (menu item have-buttons &optional before top)
|
||||
(defun easy-menu-do-add-item (menu item &optional before)
|
||||
;; 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 i.e. a list starting with the symbol `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.
|
||||
;; Optional argument BEFORE is nil or a symbol used as a key in MENU. If
|
||||
;; BEFORE is not nil put item before BEFORE in MENU, otherwise if item is
|
||||
;; already present in MENU, just change it, otherwise put it last in MENU.
|
||||
;; If optional 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 done inserted)
|
||||
;; Optional argument BEFORE is nil or a key in MENU. If BEFORE is not nil
|
||||
;; put item before BEFORE in MENU, otherwise if item is already present in
|
||||
;; MENU, just change it, otherwise put it last in MENU.
|
||||
(let (name command label prop remove)
|
||||
(cond
|
||||
((stringp item)
|
||||
(setq item-string
|
||||
(setq label
|
||||
(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))))
|
||||
item)))
|
||||
((consp item)
|
||||
(setq name (setq item-string (car item)))
|
||||
(setq command (if (keymapp (setq item (cdr item))) item
|
||||
(easy-menu-create-menu name item))))
|
||||
(setq label (setq name (car item)))
|
||||
(setq command (cdr item))
|
||||
(if (not (keymapp command))
|
||||
(setq command (easy-menu-create-menu name command)))
|
||||
(if (null command)
|
||||
;; Invisible menu item. Don't insert into keymap.
|
||||
(setq remove t)
|
||||
(when (and (symbolp command) (setq prop (get command 'menu-prop)))
|
||||
(when (null (car prop))
|
||||
(setq label (cadr prop))
|
||||
(setq prop (cddr prop)))
|
||||
(setq command (symbol-function command)))))
|
||||
((vectorp item)
|
||||
(setq name (setq item-string (aref item 0)))
|
||||
(setq command (easy-menu-make-symbol (aref item 1) t))
|
||||
(let ((active (if (> (length item) 2) (aref item 2) t))
|
||||
(active-specified (> (length item) 2))
|
||||
(count 2)
|
||||
style selected)
|
||||
(let ((active (if (> (length item) 2) (or (aref item 2) ''nil) t))
|
||||
(no-name (not (symbolp (setq command (aref item 1)))))
|
||||
cache cache-specified
|
||||
(count 2))
|
||||
(setq label (setq name (aref item 0)))
|
||||
(if no-name (setq command (easy-menu-make-symbol command)))
|
||||
(if (and (symbolp active) (= ?: (aref (symbol-name active) 0)))
|
||||
(let ((count 2) keyword arg suffix keys)
|
||||
(setq active-specified nil)
|
||||
(let ((count 2)
|
||||
keyword arg suffix visible style selected 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 active-specified t))
|
||||
((eq keyword ':suffix) (setq suffix (concat " " arg)))
|
||||
((eq keyword ':style) (setq style arg))
|
||||
((eq keyword ':selected) (setq selected arg))))
|
||||
(if keys (setq suffix (concat suffix " (" keys ")")))
|
||||
(if suffix (setq item-string (concat item-string " " suffix)))
|
||||
(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-specified 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))))
|
||||
(and (null active) active-specified
|
||||
(setq active ''nil)))
|
||||
(if active-specified (put command 'menu-enable active))))
|
||||
(t "Invalid menu item in easymenu"))
|
||||
(when name
|
||||
(and (not is-button) have-buttons
|
||||
(setq item-string (concat have-buttons item-string)))
|
||||
(setq name (intern name)))
|
||||
(setq item (cons item-string command))
|
||||
(if before (setq before (intern before)))
|
||||
;; The following loop is simlar to `define-key-after'. It
|
||||
;; inserts (name . item) in keymap menu.
|
||||
;; If name is not nil then delete any duplications.
|
||||
;; If before is not nil, insert before before. Otherwise
|
||||
;; if name is not nil and it is found in menu, insert there, else
|
||||
;; insert at end.
|
||||
((eq keyword :visible) (setq visible (or arg ''nil)))
|
||||
((eq keyword :key-sequence)
|
||||
(setq cache arg cache-specified t))
|
||||
((eq keyword :keys) (setq keys arg no-name nil))
|
||||
((eq keyword :label) (setq label arg))
|
||||
((eq keyword :active) (setq active (or arg ''nil)))
|
||||
((eq keyword :suffix) (setq suffix arg))
|
||||
((eq keyword :style) (setq style arg))
|
||||
((eq keyword :selected) (setq selected (or arg ''nil)))))
|
||||
(if (stringp suffix)
|
||||
(setq label (if (stringp label) (concat label " " suffix)
|
||||
(list 'concat label (concat " " suffix)))))
|
||||
(if (and selected
|
||||
(setq style (assq style easy-menu-button-prefix)))
|
||||
(setq prop (cons :button
|
||||
(cons (cons (cdr style) (or selected ''nil))
|
||||
prop))))
|
||||
(when (stringp keys)
|
||||
(if (string-match "^[^\\]*\\(\\\\\\[\\([^]]+\\)]\\)[^\\]*$"
|
||||
keys)
|
||||
(let ((prefix
|
||||
(if (< (match-beginning 0) (match-beginning 1))
|
||||
(substring keys 0 (match-beginning 1))))
|
||||
(postfix
|
||||
(if (< (match-end 1) (match-end 0))
|
||||
(substring keys (match-end 1))))
|
||||
(cmd (intern (substring keys (match-beginning 2)
|
||||
(match-end 2)))))
|
||||
(setq keys
|
||||
(and (or prefix postfix (not (eq command cmd)))
|
||||
(cons cmd
|
||||
(and (or prefix postfix)
|
||||
(cons prefix postfix))))))
|
||||
(setq cache-specified nil))
|
||||
(if keys (setq prop (cons :keys (cons keys prop)))))
|
||||
(if (and visible (not (easy-menu-always-true visible)))
|
||||
(if (equal visible ''nil)
|
||||
;; Invisible menu item. Don't insert into keymap.
|
||||
(setq remove t)
|
||||
(setq prop (cons :visible (cons visible prop)))))))
|
||||
(if (and active (not (easy-menu-always-true active)))
|
||||
(setq prop (cons :enable (cons active prop))))
|
||||
(if (and (or no-name cache-specified)
|
||||
(or (null cache) (stringp cache) (vectorp cache)))
|
||||
(setq prop (cons :key-sequence (cons cache prop))))))
|
||||
(t (error "Invalid menu item in easymenu.")))
|
||||
(easy-menu-define-key menu (if (stringp name) (intern name) name)
|
||||
(and (not remove)
|
||||
(cons 'menu-item
|
||||
(cons label
|
||||
(and name (cons command prop)))))
|
||||
(if (stringp before) (intern before) before))))
|
||||
|
||||
(defun easy-menu-define-key (menu key item &optional before)
|
||||
;; Add binding in MENU for KEY => ITEM. Similar to `define-key-after'.
|
||||
;; If KEY is not nil then delete any duplications. If ITEM is nil, then
|
||||
;; don't insert, only delete.
|
||||
;; Optional argument BEFORE is nil or a key in MENU. If BEFORE is not nil
|
||||
;; put binding before BEFORE in MENU, otherwise if binding is already
|
||||
;; present in MENU, just change it, otherwise put it last in MENU.
|
||||
(let ((inserted (null item)) ; Fake already inserted.
|
||||
done)
|
||||
(while (not done)
|
||||
(cond
|
||||
((or (setq done (or (null (cdr menu)) (keymapp (cdr menu))))
|
||||
(and before (eq (car-safe (cadr menu)) before)))
|
||||
;; If name is nil, stop here, otherwise keep going past the
|
||||
(and before (equal (car-safe (cadr menu)) before)))
|
||||
;; If key is nil, stop here, otherwise keep going past the
|
||||
;; inserted element so we can delete any duplications that come
|
||||
;; later.
|
||||
(if (null name) (setq done t))
|
||||
(if (null key) (setq done t))
|
||||
(unless inserted ; Don't insert more than once.
|
||||
(setcdr menu (cons (cons name item) (cdr menu)))
|
||||
(setcdr menu (cons (cons key item) (cdr menu)))
|
||||
(setq inserted t)
|
||||
(setq menu (cdr menu))))
|
||||
((and name (eq (car-safe (cadr menu)) name))
|
||||
(if (and before ; Wanted elsewere and
|
||||
(not (setq done ; not the last in this keymap.
|
||||
(or (null (cddr menu)) (keymapp (cddr menu))))))
|
||||
(setcdr menu (cddr menu))
|
||||
(setcdr (cadr menu) item) ; Change item.
|
||||
((and key (equal (car-safe (cadr menu)) key))
|
||||
(if (and (or inserted ; Already inserted or
|
||||
before) ; wanted elsewhere and
|
||||
(or (not (setq done ; not the last in this keymap.
|
||||
(or (null (cddr menu))
|
||||
(keymapp (cddr menu)))))
|
||||
inserted))
|
||||
;; The contorted logic above, guarantees `done' has been computed.
|
||||
(setcdr menu (cddr menu)) ; Remove item.
|
||||
(setcdr (cadr menu) item) ; Change item.
|
||||
(setq inserted t))))
|
||||
(setq menu (cdr menu)))
|
||||
have-buttons))
|
||||
(setq menu (cdr menu)))))
|
||||
|
||||
(defun easy-menu-always-true (x)
|
||||
;; Return true if X never evaluates to nil.
|
||||
(if (consp x) (and (eq (car x) 'quote) (cadr x))
|
||||
(or (eq x t) (not (symbolp x)))))
|
||||
|
||||
(defvar easy-menu-item-count 0)
|
||||
|
||||
(defun easy-menu-make-symbol (callback &optional call)
|
||||
(defun easy-menu-make-symbol (callback)
|
||||
;; 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))))
|
||||
(if (keymapp callback) callback
|
||||
`(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 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)
|
||||
;; No change, just use the active value.
|
||||
active
|
||||
;; It has changed. Update the entry.
|
||||
(aset item 1 new)
|
||||
;; If the entry is active, make sure the menu gets updated by
|
||||
;; returning a different value than last time to cheat the cache.
|
||||
(and active
|
||||
(random)))))
|
||||
|
||||
(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
|
||||
|
|
@ -348,22 +352,18 @@ 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))))
|
||||
(setq menu (easy-menu-get-map menu path))
|
||||
(if (or (keymapp item)
|
||||
(and (symbolp item) (keymapp (symbol-value item))))
|
||||
;; Item is a keymap, find the prompt string and use as item name.
|
||||
(let ((tail (easy-menu-get-map item nil)) name)
|
||||
(if (not (keymapp item)) (setq item tail))
|
||||
(while (and (null name) (consp (setq tail (cdr tail)))
|
||||
(not (keymapp tail)))
|
||||
(if (stringp (car tail)) (setq name (car tail)) ; Got a name.
|
||||
(setq tail (cdr tail))))
|
||||
(setq item (cons name item))))
|
||||
(easy-menu-do-add-item menu item
|
||||
(and (not top) (easy-menu-have-button menu)
|
||||
" ")
|
||||
before top)))
|
||||
(setq menu (easy-menu-get-map menu path))
|
||||
(if (or (keymapp item)
|
||||
(and (symbolp item) (keymapp (symbol-value item))))
|
||||
;; Item is a keymap, find the prompt string and use as item name.
|
||||
(let ((tail (easy-menu-get-map item nil)) name)
|
||||
(if (not (keymapp item)) (setq item tail))
|
||||
(while (and (null name) (consp (setq tail (cdr tail)))
|
||||
(not (keymapp tail)))
|
||||
(if (stringp (car tail)) (setq name (car tail)) ; Got a name.
|
||||
(setq tail (cdr tail))))
|
||||
(setq item (cons name item))))
|
||||
(easy-menu-do-add-item menu item before))
|
||||
|
||||
(defun easy-menu-item-present-p (menu path name)
|
||||
"In submenu of MENU with path PATH, return true iff item NAME is present.
|
||||
|
|
@ -375,21 +375,11 @@ NAME should be a string, the name of the element to be looked for."
|
|||
"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)))))
|
||||
(easy-menu-define-key (easy-menu-get-map menu path) (intern name) 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'.
|
||||
;; MENU and PATH are as defined in `easy-menu-add-item'.
|
||||
(if (null menu)
|
||||
(setq menu (key-binding (vconcat '(menu-bar) (mapcar 'intern path))))
|
||||
(if (and (symbolp menu) (not (keymapp menu)))
|
||||
|
|
@ -400,50 +390,6 @@ NAME should be a string, the name of the element to be removed."
|
|||
(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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue