X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/4d6d04b50405da93ac1840e0834362533cb057b4..1042fe8c8ca167fdb44365d99a35492df87b078f:/lisp/emacs-lisp/easymenu.el diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 221a7a9c39..2bed70866a 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -1,9 +1,9 @@ -;;; easymenu.el --- support the easymenu interface for defining a menu. +;;; easymenu.el --- support the easymenu interface for defining a menu -;; Copyright (C) 1994, 1996, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. ;; Keywords: emulations -;; Author: rms +;; Author: Richard Stallman ;; This file is part of GNU Emacs. @@ -41,11 +41,18 @@ menus, turn this variable off, otherwise it is probably better to keep it on." :group 'menu :version "20.3") +(defsubst easy-menu-intern (s) + (if (stringp s) (intern (downcase s)) s)) + +;;;###autoload +(put 'easy-menu-define 'lisp-indent-function 'defun) ;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) "Define a menu bar submenu in maps MAPS, according to MENU. -The menu keymap is stored in symbol SYMBOL, both as its value -and as its function definition. DOC is used as the doc string for SYMBOL. + +If SYMBOL is non-nil, store the menu keymap in the value of SYMBOL, +and define SYMBOL as a function to pop up the menu, with DOC as its doc string. +If SYMBOL is nil, just store the menu keymap into MAPS. The first element of MENU must be a string. It is the menu bar item name. It may be followed by the following keyword argument pairs @@ -141,7 +148,7 @@ as a solid horizontal line. A menu item can be a list with the same format as MENU. This is a submenu." `(progn - (defvar ,symbol nil ,doc) + ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) ;;;###autoload @@ -151,21 +158,22 @@ A menu item can be a list with the same format as MENU. This is a submenu." ;; compatible. Therefore everything interesting is done in this ;; function. (let ((keymap (easy-menu-create-menu (car menu) (cdr menu)))) - (set symbol keymap) - (fset symbol - `(lambda (event) ,doc (interactive "@e") - ;; FIXME: XEmacs uses popup-menu which calls the binding - ;; while x-popup-menu only returns the selection. - (x-popup-menu event - (or (and (symbolp ,symbol) - (funcall - (or (plist-get (get ,symbol 'menu-prop) - :filter) - 'identity) - (symbol-function ,symbol))) - ,symbol)))) + (when symbol + (set symbol keymap) + (fset symbol + `(lambda (event) ,doc (interactive "@e") + ;; FIXME: XEmacs uses popup-menu which calls the binding + ;; while x-popup-menu only returns the selection. + (x-popup-menu event + (or (and (symbolp ,symbol) + (funcall + (or (plist-get (get ,symbol 'menu-prop) + :filter) + 'identity) + (symbol-function ,symbol))) + ,symbol))))) (mapcar (lambda (map) - (define-key map (vector 'menu-bar (intern (car menu))) + (define-key map (vector 'menu-bar (easy-menu-intern (car menu))) (cons 'menu-item (cons (car menu) (if (not (symbolp keymap)) @@ -182,11 +190,15 @@ 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. If NAME is provided, it is used for the keymap." - (when (and (not (keymapp menu)) (consp menu)) + (cond + ((and (not (keymapp menu)) (consp menu)) ;; If it's a cons but not a keymap, then it can't be right ;; unless it's an XEmacs menu. (setq menu (easy-menu-create-menu (or name "") menu))) - (easy-menu-get-map menu nil)) ; Get past indirections. + ((vectorp menu) + ;; It's just a menu entry. + (setq menu (cdr (easy-menu-convert-item menu))))) + menu) ;;;###autoload (defun easy-menu-create-menu (menu-name menu-items) @@ -238,7 +250,7 @@ possibly preceded by keyword pairs as described in `easy-menu-define'." (defun easy-menu-do-add-item (menu item &optional before) (setq item (easy-menu-convert-item item)) - (easy-menu-define-key-intern menu (car item) (cdr item) before)) + (easy-menu-define-key menu (easy-menu-intern (car item)) (cdr item) before)) (defvar easy-menu-converted-items-table (make-hash-table :test 'equal)) @@ -254,14 +266,8 @@ would always fail because the key is `equal' but not `eq'." easy-menu-converted-items-table))) (defun easy-menu-convert-item-1 (item) - "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'. -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." + "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. @@ -331,8 +337,7 @@ MENU, just change it, otherwise put it last in MENU." (postfix (if (< (match-end 1) (match-end 0)) (substring keys (match-end 1)))) - (cmd (intern (substring keys (match-beginning 2) - (match-end 2))))) + (cmd (intern (match-string 2 keys)))) (setq keys (and (or prefix postfix) (cons prefix postfix))) (setq keys @@ -351,32 +356,34 @@ MENU, just change it, otherwise put it last in MENU." (or (null cache) (stringp cache) (vectorp cache))) (setq prop (cons :key-sequence (cons cache prop)))))) (t (error "Invalid menu item in easymenu"))) - (cons name (and (not remove) - (cons 'menu-item - (cons label - (and name - (cons command prop)))))))) - -(defun easy-menu-define-key-intern (menu key item &optional before) - "Like easy-menu-define-key, but interns KEY and BEFORE if they are strings." - (easy-menu-define-key menu (if (stringp key) (intern key) key) item - (if (stringp before) (intern before) before))) + ;; `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 -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. -KEY and BEFORE don't have to be symbols, comparison is done with equal -not with eq." +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." (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 (equal (car-safe (cadr menu)) before))) + (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. @@ -391,15 +398,31 @@ not with eq." (and before ; wanted elsewhere and (setq tail (cddr menu)) ; not last item and not (not (keymapp tail)) - (not (equal (car-safe (car tail)) before)))) ; in position + (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." + (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)) + (eq (car-safe item) (easy-menu-intern name))))))) + (defun easy-menu-always-true (x) - "Return true if X never evaluates to nil." + "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))))) @@ -413,7 +436,7 @@ When non-nil, NOEXP indicates that CALLBACK cannot be an expression (make-symbol (format "menu-function-%d" easy-menu-item-count)))) (setq easy-menu-item-count (1+ easy-menu-item-count)) (fset command - (if (or (keymapp callback) noexp) callback + (if (or (keymapp callback) (functionp callback) noexp) callback `(lambda () (interactive) ,callback))) command)) @@ -431,23 +454,41 @@ the submenu named BEFORE, otherwise add it at the end of the menu. 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)) + (easy-menu-add-item nil path (easy-menu-create-menu 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 easy-menu-remove is a noop and easy-menu-add only precalculates ;; equivalent keybindings (if easy-menu-precalculate-equivalent-keybindings ;; is on). -(defalias 'easy-menu-remove 'ignore) +(defalias 'easy-menu-remove 'ignore + "Remove MENU from the current menu bar. +Contrary to XEmacs, this is a nop on Emacs since menus are automatically +\(de)activated when the corresponding keymap is (de)activated. + +\(fn MENU)") (defun easy-menu-add (menu &optional map) - "Maybe precalculate equivalent key bindings. -Do it if `easy-menu-precalculate-equivalent-keybindings' is on," + "Add the menu to the menubar. +This is a nop on Emacs since menus are automatically activated when the +corresponding keymap is activated. On XEmacs this is needed to actually +add the menu to the current menubar. +Maybe precalculate equivalent key bindings. +Do it only if `easy-menu-precalculate-equivalent-keybindings' is on." (when easy-menu-precalculate-equivalent-keybindings (if (and (symbolp menu) (not (keymapp menu)) (boundp menu)) (setq menu (symbol-value menu))) (if (keymapp menu) (x-popup-menu nil menu)))) +(defun add-submenu (menu-path submenu &optional before in-menu) + "Add submenu SUBMENU in the menu at MENU-PATH. +If BEFORE is non-nil, add before the item named BEFORE. +If IN-MENU is non-nil, follow MENU-PATH in IN-MENU. +This is a compatibility function; use `easy-menu-add-item'." + (easy-menu-add-item (or in-menu (current-global-map)) + (cons "menu-bar" menu-path) + submenu before)) + (defun easy-menu-add-item (map path item &optional before) "To the submenu of MAP with path PATH, add ITEM. @@ -457,7 +498,7 @@ In the latter case, ITEM is normally added at the end of the submenu. However, if BEFORE is a string and there is an item in the submenu with that name, then ITEM is added before that item. -MAP should normally be a keymap; nil stands for the global menu-bar keymap. +MAP should normally be a keymap; nil stands for the local menu-bar keymap. It can also be a symbol, which has earlier been used as the first argument in a call to `easy-menu-define', or the value of such a symbol. @@ -476,7 +517,8 @@ earlier by `easy-menu-define' or `easy-menu-create-menu'." (if (and (consp item) (consp (cdr item)) (eq (cadr item) 'menu-item)) ;; This is a value returned by `easy-menu-item-present-p' or ;; `easy-menu-remove-item'. - (easy-menu-define-key-intern map (car item) (cdr item) before) + (easy-menu-define-key map (easy-menu-intern (car item)) + (cdr item) before) (if (or (keymapp item) (and (symbolp item) (keymapp (symbol-value item)))) ;; Item is a keymap, find the prompt string and use as item name. @@ -501,18 +543,16 @@ MAP and PATH are defined as in `easy-menu-add-item'. NAME should be a string, the name of the element to be removed." (setq map (easy-menu-get-map map path)) (let ((ret (easy-menu-return-item map name))) - (if ret (easy-menu-define-key-intern map name nil)) + (if ret (easy-menu-define-key map (easy-menu-intern name) nil)) ret)) (defun easy-menu-return-item (menu name) "In menu MENU try to look for menu item with name NAME. If a menu item is found, return (NAME . item), otherwise return nil. If item is an old format item, a new format item is returned." - (let ((item (lookup-key menu (vector (intern name)))) + (let ((item (lookup-key menu (vector (easy-menu-intern name)))) ret enable cache label) (cond - ((or (keymapp item) (eq (car-safe item) 'menu-item)) - (cons name item)) ; Keymap or new menu format ((stringp (car-safe item)) ;; This is the old menu format. Convert it to new format. (setq label (car item)) @@ -526,11 +566,13 @@ If item is an old format item, a new format item is returned." (and (symbolp item) (setq enable (get item 'menu-enable)) ; Got enable (setq ret (cons :enable (cons enable ret)))) (if cache (setq ret (cons cache ret))) - (cons name (cons 'menu-enable (cons label (cons item ret)))))))) + (cons name (cons 'menu-enable (cons label (cons item ret))))) + (item ; (or (symbolp item) (keymapp item) (eq (car-safe item) 'menu-item)) + (cons name item)) ; Keymap or new menu format + ))) (defun easy-menu-get-map-look-for-name (name submap) - (while (and submap (not (or (equal (car-safe (cdr-safe (car submap))) name) - (equal (car-safe (cdr-safe (cdr-safe (car submap)))) name)))) + (while (and submap (not (easy-menu-name-match name (car submap)))) (setq submap (cdr submap))) submap) @@ -541,33 +583,38 @@ MAP and PATH are as defined in `easy-menu-add-item'. TO-MODIFY, if non-nil, is the name of the item the caller wants to modify in the map that we return. In some cases we use that to select between the local and global maps." - (if (null map) - (let ((local (and (current-local-map) - (lookup-key (current-local-map) - (vconcat '(menu-bar) (mapcar 'intern path))))) - (global (lookup-key global-map - (vconcat '(menu-bar) (mapcar 'intern path))))) - (cond ((and to-modify local (not (integerp local)) - (easy-menu-get-map-look-for-name to-modify local)) - (setq map local)) - ((and to-modify global (not (integerp global)) - (easy-menu-get-map-look-for-name to-modify global)) - (setq map global)) - ((and local local (not (integerp local))) - (setq map local)) - ((and global (not (integerp global))) - (setq map global)) - (t - (setq map (make-sparse-keymap)) - (define-key (current-local-map) - (vconcat '(menu-bar) (mapcar 'intern path)) map)))) - (if (and (symbolp map) (not (keymapp map))) - (setq map (symbol-value map))) - (if path (setq map (lookup-key map (vconcat (mapcar 'intern path)))))) - (while (and (symbolp map) (keymapp map)) - (setq map (symbol-function map))) - (unless map - (error "Menu specified in easy-menu is not defined")) + (setq map + (catch 'found + (let* ((key (vconcat (unless map '(menu-bar)) + (mapcar 'easy-menu-intern path))) + (maps (mapcar (lambda (map) + (setq map (lookup-key map key)) + (while (and (symbolp map) (keymapp map)) + (setq map (symbol-function map))) + map) + (if map + (list (if (and (symbolp map) + (not (keymapp map))) + (symbol-value map) map)) + (current-active-maps))))) + ;; Prefer a map that already contains the to-be-modified entry. + (when to-modify + (dolist (map maps) + (when (and (keymapp map) + (easy-menu-get-map-look-for-name to-modify map)) + (throw 'found map)))) + ;; Use the first valid map. + (dolist (map maps) + (when (keymapp map) + (throw 'found map))) + ;; Otherwise, make one up. + ;; Hardcoding current-local-map is lame, but it's difficult + ;; to know what the caller intended for us to do ;-( + (let* ((name (if path (format "%s" (car (reverse path))))) + (newmap (make-sparse-keymap name))) + (define-key (or map (current-local-map)) key + (if name (cons name newmap) newmap)) + newmap)))) (or (keymapp map) (error "Malformed menu in easy-menu: (%s)" map)) map)