-(defun easy-menu-create-keymaps (menu-name menu-items)
- (let ((menu (make-sparse-keymap menu-name)))
- ;; 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)))
- command enabler name)
- (cond ((stringp item)
- (setq command nil)
- (setq name (if (string-match "^-+$" item) "" item)))
- ((consp item)
- (setq command (easy-menu-create-keymaps (car item) (cdr item)))
- (setq name (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 (aref item 0))
- (let ((keyword (aref item 2)))
- (if (and (symbolp keyword)
- (= ?: (aref (symbol-name keyword) 0)))
- (let ((count 2)
- style selected active keys
- 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 arg))
- ((eq keyword ':suffix)
- (setq name (concat name " " arg)))
- ((eq keyword ':style)
- (setq style arg))
- ((eq keyword ':selected)
- (setq selected arg))))
- (if keys
- (setq name (concat name " (" keys ")")))
- (if (eq style 'toggle)
- ;; Simulate checkboxes.
- (setq name (concat "Toggle " name)))
- (if active
- (put command 'menu-enable active)
- (and (eq style 'radio)
- selected
- ;; Simulate radio buttons with menu-enable.
- (put command 'menu-enable
- (list 'not selected)))))
- (put command 'menu-enable keyword)))
- (if (keymapp callback)
- (setq name (concat name " ...")))
- (if (symbolp callback)
- (fset command callback)
- (fset command (list 'lambda () '(interactive) callback)))))
- (if (null command)
- ;; Handle inactive strings specially--allow any number
- ;; of identical ones.
- (setcdr menu (cons (list nil name) (cdr menu)))
- (if name
- (define-key menu (vector (intern name)) (cons name command)))))
- (setq menu-items (cdr menu-items)))
- menu))
-
-(defun easy-menu-change (path name items)
- "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.
+(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))
+ prop keyword arg label enable filter visible help)
+ ;; Look for keywords.
+ (while (and menu-items
+ (cdr menu-items)
+ (keywordp (setq keyword (car menu-items))))
+ (setq arg (cadr menu-items))
+ (setq menu-items (cddr menu-items))
+ (cond
+ ((eq keyword :filter)
+ (setq filter `(lambda (menu)
+ (easy-menu-filter-return (,arg menu) ,menu-name))))
+ ((eq keyword :active) (setq enable (or arg ''nil)))
+ ((eq keyword :label) (setq label arg))
+ ((eq keyword :help) (setq help arg))
+ ((or (eq keyword :included) (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-p visible)))
+ (setq prop (cons :visible (cons visible prop))))
+ (if (and enable (not (easy-menu-always-true-p enable)))
+ (setq prop (cons :enable (cons enable prop))))
+ (if filter (setq prop (cons :filter (cons filter prop))))
+ (if help (setq prop (cons :help (cons help prop))))
+ (if label (setq prop (cons nil (cons label prop))))
+ (if filter
+ ;; The filter expects the menu in its XEmacs form and the pre-filter
+ ;; form will only be passed to the filter anyway, so we'd better
+ ;; not convert it at all (it will be converted on the fly by
+ ;; easy-menu-filter-return).
+ (setq menu menu-items)
+ (setq menu (append menu (mapcar 'easy-menu-convert-item menu-items))))
+ (when prop
+ (setq menu (easy-menu-make-symbol menu 'noexp))
+ (put menu 'menu-prop prop))
+ menu)))
+
+
+;; Known button types.
+(defvar easy-menu-button-prefix
+ '((radio . :radio) (toggle . :toggle)))
+
+(defun easy-menu-do-add-item (menu item &optional before)
+ (setq item (easy-menu-convert-item item))
+ (easy-menu-define-key menu (easy-menu-intern (car item)) (cdr item) before))
+
+(defvar easy-menu-converted-items-table (make-hash-table :test 'equal))
+
+(defun easy-menu-convert-item (item)
+ "Memoize the value returned by `easy-menu-convert-item-1' called on ITEM.
+This makes key-shortcut-caching work a *lot* better when this
+conversion is done from within a filter.
+This also helps when the NAME of the entry is recreated each time:
+since the menu is built and traversed separately, the lookup
+would always fail because the key is `equal' but not `eq'."
+ (or (gethash item easy-menu-converted-items-table)
+ (puthash item (easy-menu-convert-item-1 item)
+ easy-menu-converted-items-table)))
+
+(defun easy-menu-convert-item-1 (item)
+ "Parse an item description and convert it to a menu keymap element.
+ITEM defines an item as in `easy-menu-define'."
+ (let (name command label prop remove help)
+ (cond
+ ((stringp item) ; An item or separator.
+ (setq label item))
+ ((consp item) ; A sub-menu
+ (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) ; An item.
+ (let* ((ilen (length item))
+ (active (if (> ilen 2) (or (aref item 2) ''nil) t))
+ (no-name (not (symbolp (setq command (aref item 1)))))
+ cache cache-specified)
+ (setq label (setq name (aref item 0)))
+ (if no-name (setq command (easy-menu-make-symbol command)))
+ (if (keywordp active)
+ (let ((count 2)
+ keyword arg suffix visible style selected keys)
+ (setq active nil)
+ (while (> ilen count)
+ (setq keyword (aref item count))
+ (setq arg (aref item (1+ count)))
+ (setq count (+ 2 count))
+ (cond
+ ((or (eq keyword :included) (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 :help) (setq prop (cons :help (cons arg prop))))
+ ((eq keyword :suffix) (setq suffix arg))
+ ((eq keyword :style) (setq style arg))
+ ((eq keyword :selected) (setq selected (or arg ''nil)))))
+ (if suffix
+ (setq label
+ (if (stringp suffix)
+ (if (stringp label) (concat label " " suffix)
+ (list 'concat label (concat " " suffix)))
+ (if (stringp label)
+ (list 'concat (concat label " ") suffix)
+ (list 'concat label " " suffix)))))
+ (cond
+ ((eq style 'button)
+ (setq label (if (stringp label) (concat "[" label "]")
+ (list 'concat "[" label "]"))))
+ ((and selected
+ (setq style (assq style easy-menu-button-prefix)))
+ (setq prop (cons :button
+ (cons (cons (cdr style) selected) 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 (match-string 2 keys))))
+ (setq keys (and (or prefix postfix)
+ (cons prefix postfix)))
+ (setq keys
+ (and (or keys (not (eq command cmd)))
+ (cons cmd keys))))
+ (setq cache-specified nil))
+ (if keys (setq prop (cons :keys (cons keys prop)))))
+ (if (and visible (not (easy-menu-always-true-p 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-p 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")))
+ ;; `intern' the name so as to merge multiple entries with the same name.
+ ;; It also makes it easier/possible to lookup/change menu bindings
+ ;; via keymap functions.
+ (cons (easy-menu-intern name)
+ (and (not remove)
+ (cons 'menu-item
+ (cons label
+ (and name
+ (cons command prop))))))))
+
+(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 delete the definition of KEY.
+
+Optional argument BEFORE is nil or a key in MENU. If BEFORE is not nil,
+put binding before the item in MENU named BEFORE; otherwise,
+if a binding for KEY is already present in MENU, just change it;
+otherwise put the new binding last in MENU.
+BEFORE can be either a string (menu item name) or a symbol
+\(the fake function key for the menu item).
+KEY does not have to be a symbol, and comparison is done with equal."
+ (if (symbolp menu) (setq menu (indirect-function menu)))
+ (let ((inserted (null item)) ; Fake already inserted.
+ tail done)
+ (while (not done)
+ (cond
+ ((or (setq done (or (null (cdr menu)) (keymapp (cdr menu))))
+ (and before (easy-menu-name-match before (cadr menu))))
+ ;; If key is nil, stop here, otherwise keep going past the
+ ;; inserted element so we can delete any duplications that come
+ ;; later.
+ (if (null key) (setq done t))
+ (unless inserted ; Don't insert more than once.
+ (setcdr menu (cons (cons key item) (cdr menu)))
+ (setq inserted t)
+ (setq menu (cdr menu)))
+ (setq menu (cdr menu)))
+ ((and key (equal (car-safe (cadr menu)) key))
+ (if (or inserted ; Already inserted or
+ (and before ; wanted elsewhere and
+ (setq tail (cddr menu)) ; not last item and not
+ (not (keymapp tail))
+ (not (easy-menu-name-match
+ before (car tail))))) ; in position
+ (setcdr menu (cddr menu)) ; Remove item.
+ (setcdr (cadr menu) item) ; Change item.
+ (setq inserted t)
+ (setq menu (cdr menu))))
+ (t (setq menu (cdr menu)))))))
+
+(defun easy-menu-name-match (name item)
+ "Return t if NAME is the name of menu item ITEM.
+NAME can be either a string, or a symbol.
+ITEM should be a keymap binding of the form (KEY . MENU-ITEM)."
+ (if (consp item)
+ (if (symbolp name)
+ (eq (car-safe item) name)
+ (if (stringp name)
+ ;; Match against the text that is displayed to the user.
+ (or (condition-case nil (member-ignore-case name item)
+ (error nil)) ;`item' might not be a proper list.
+ ;; Also check the string version of the symbol name,
+ ;; for backwards compatibility.
+ (eq (car-safe item) (intern name)))))))
+
+(defun easy-menu-always-true-p (x)
+ "Return true if form X never evaluates to nil."
+ (if (consp x) (and (eq (car x) 'quote) (cadr x))
+ (or (eq x t) (not (symbolp x)))))