code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/easymenu.el

   1 ;;; easymenu.el --- support the easymenu interface for defining a menu.
   2
   3 ;; Copyright (C) 1994, 1996, 1998 Free Software Foundation, Inc.
   4
   5 ;; Keywords: emulations
   6 ;; Author: rms
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This is compatible with easymenu.el by Per Abrahamsen
  28 ;; but it is much simpler as it doesn't try to support other Emacs versions.
  29 ;; The code was mostly derived from lmenu.el.
  30
  31 ;;; Code:
  32
  33 (defcustom easy-menu-precalculate-equivalent-keybindings t
  34   "Determine when equivalent key bindings are computed for easy-menu menus.
  35 It can take some time to calculate the equivalent key bindings that are shown
  36 in a menu.  If the variable is on, then this calculation gives a (maybe
  37 noticeable) delay when a mode is first entered.  If the variable is off, then
  38 this delay will come when a menu is displayed the first time.  If you never use
  39 menus, turn this variable off, otherwise it is probably better to keep it on."
  40   :type 'boolean
  41   :group 'menu
  42   :version "20.3")
  43
  44 ;;;###autoload
  45 (defmacro easy-menu-define (symbol maps doc menu)
  46   "Define a menu bar submenu in maps MAPS, according to MENU.
  47 The menu keymap is stored in symbol SYMBOL, both as its value
  48 and as its function definition.   DOC is used as the doc string for SYMBOL.
  49
  50 The first element of MENU must be a string.  It is the menu bar item name.
  51 It may be followed by the keyword argument pair
  52    :filter FUNCTION
  53 FUNCTION is a function with one argument, the menu.  It returns the actual
  54 menu displayed.
  55
  56 The rest of the elements are menu items.
  57
  58 A menu item is usually a vector of three elements:  [NAME CALLBACK ENABLE]
  59
  60 NAME is a string--the menu item name.
  61
  62 CALLBACK is a command to run when the item is chosen,
  63 or a list to evaluate when the item is chosen.
  64
  65 ENABLE is an expression; the item is enabled for selection
  66 whenever this expression's value is non-nil.
  67
  68 Alternatively, a menu item may have the form:
  69
  70    [ NAME CALLBACK [ KEYWORD ARG ] ... ]
  71
  72 Where KEYWORD is one of the symbols defined below.
  73
  74    :keys KEYS
  75
  76 KEYS is a string; a complex keyboard equivalent to this menu item.
  77 This is normally not needed because keyboard equivalents are usually
  78 computed automatically.
  79
  80    :active ENABLE
  81
  82 ENABLE is an expression; the item is enabled for selection
  83 whenever this expression's value is non-nil.
  84
  85    :suffix NAME
  86
  87 NAME is a string; the name of an argument to CALLBACK.
  88
  89    :style STYLE
  90
  91 STYLE is a symbol describing the type of menu item.  The following are
  92 defined:
  93
  94 toggle: A checkbox.
  95         Prepend the name with '(*) ' or '( ) ' depending on if selected or not.
  96 radio: A radio button.
  97        Prepend the name with '[X] ' or '[ ] ' depending on if selected or not.
  98 nil: An ordinary menu item.
  99
 100    :selected SELECTED
 101
 102 SELECTED is an expression; the checkbox or radio button is selected
 103 whenever this expression's value is non-nil.
 104
 105 A menu item can be a string.  Then that string appears in the menu as
 106 unselectable text.  A string consisting solely of hyphens is displayed
 107 as a solid horizontal line.
 108
 109 A menu item can be a list.  It is treated as a submenu.
 110 The first element should be the submenu name.  That's used as the
 111 menu item name in the top-level menu.  It may be followed by the :filter
 112 FUNCTION keyword argument pair.  The rest of the submenu list are menu items,
 113 as above."
 114   `(progn
 115      (defvar ,symbol nil ,doc)
 116      (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
 117
 118 ;;;###autoload
 119 (defun easy-menu-do-define (symbol maps doc menu)
 120   ;; We can't do anything that might differ between Emacs dialects in
 121   ;; `easy-menu-define' in order to make byte compiled files
 122   ;; compatible.  Therefore everything interesting is done in this
 123   ;; function.
 124   (set symbol (easy-menu-create-menu (car menu) (cdr menu)))
 125   (fset symbol (` (lambda (event) (, doc) (interactive "@e")
 126                     (x-popup-menu event (, symbol)))))
 127   (mapcar (function (lambda (map)
 128             (define-key map (vector 'menu-bar (intern (car menu)))
 129               (cons (car menu) (symbol-value symbol)))))
 130           (if (keymapp maps) (list maps) maps)))
 131
 132 (defun easy-menu-filter-return (menu)
 133  "Convert MENU to the right thing to return from a menu filter.
 134 MENU is a menu as computed by `easy-menu-define' or `easy-menu-create-menu' or
 135 a symbol whose value is such a menu.
 136 In Emacs a menu filter must return a menu (a keymap), in XEmacs a filter must
 137 return a menu items list (without menu name and keywords). This function
 138 returns the right thing in the two cases."
 139  (easy-menu-get-map menu nil))          ; Get past indirections.
 140
 141 ;;;###autoload
 142 (defun easy-menu-create-menu (menu-name menu-items)
 143   "Create a menu called MENU-NAME with items described in MENU-ITEMS.
 144 MENU-NAME is a string, the name of the menu.  MENU-ITEMS is a list of items
 145 possibly preceded by keyword pairs as described in `easy-menu-define'."
 146   (let ((menu (make-sparse-keymap menu-name))
 147         prop keyword arg label enable filter visible)
 148     ;; Look for keywords.
 149     (while (and menu-items (cdr menu-items)
 150                 (symbolp (setq keyword (car menu-items)))
 151                 (= ?: (aref (symbol-name keyword) 0)))
 152       (setq arg (cadr menu-items))
 153       (setq menu-items (cddr menu-items))
 154       (cond
 155        ((eq keyword ':filter) (setq filter arg))
 156        ((eq keyword ':active) (setq enable (or arg ''nil)))
 157        ((eq keyword ':label) (setq label arg))
 158        ((eq keyword ':visible) (setq visible (or arg ''nil)))))
 159     (if (equal visible ''nil) nil       ; Invisible menu entry, return nil.
 160       (if (and visible (not (easy-menu-always-true visible)))
 161           (setq prop (cons :visible (cons visible prop))))
 162       (if (and enable (not (easy-menu-always-true enable)))
 163           (setq prop (cons :enable (cons enable prop))))
 164       (if filter (setq prop (cons :filter (cons filter prop))))
 165       (if label (setq prop (cons nil (cons label prop))))
 166       (while menu-items
 167         (easy-menu-do-add-item menu (car menu-items))
 168         (setq menu-items (cdr menu-items)))
 169       (when prop
 170         (setq menu (easy-menu-make-symbol menu))
 171         (put menu 'menu-prop prop))
 172       menu)))
 173
 174
 175 ;; Button prefixes.
 176 (defvar easy-menu-button-prefix
 177   '((radio . :radio) (toggle . :toggle)))
 178
 179 (defun easy-menu-do-add-item (menu item &optional before)
 180   ;; Parse an item description and add the item to a keymap.  This is
 181   ;; the function that is used for item definition by the other easy-menu
 182   ;; functions.
 183   ;; MENU is a sparse keymap i.e. a list starting with the symbol `keymap'.
 184   ;; ITEM defines an item as in `easy-menu-define'.
 185   ;; Optional argument BEFORE is nil or a key in MENU.  If BEFORE is not nil
 186   ;; put item before BEFORE in MENU, otherwise if item is already present in
 187   ;; MENU, just change it, otherwise put it last in MENU.
 188   (let (name command label prop remove)
 189     (cond
 190      ((stringp item)
 191       (setq label
 192             (if (string-match   ; If an XEmacs separator
 193                  "^\\(-+\\|\
 194 --:\\(\\(no\\|\\(sing\\|doub\\)le\\(Dashed\\)?\\)Line\\|\
 195 shadow\\(Double\\)?Etched\\(In\\|Out\\)\\(Dash\\)?\\)\\)$"
 196                  item) ""               ; use a single line separator.
 197               item)))
 198      ((consp item)
 199       (setq label (setq name (car item)))
 200       (setq command (cdr item))
 201       (if (not (keymapp command))
 202           (setq command (easy-menu-create-menu name command)))
 203       (if (null command)
 204           ;; Invisible menu item. Don't insert into keymap.
 205           (setq remove t)
 206         (when (and (symbolp command) (setq prop (get command 'menu-prop)))
 207           (when (null (car prop))
 208             (setq label (cadr prop))
 209             (setq prop (cddr prop)))
 210           (setq command (symbol-function command)))))
 211      ((vectorp item)
 212       (let* ((ilen (length item))
 213              (active (if (> ilen 2) (or (aref item 2) ''nil) t))
 214              (no-name (not (symbolp (setq command (aref item 1)))))
 215              cache cache-specified)
 216         (setq label (setq name (aref item 0)))
 217         (if no-name (setq command (easy-menu-make-symbol command)))
 218         (if (and (symbolp active) (= ?: (aref (symbol-name active) 0)))
 219             (let ((count 2)
 220                   keyword arg suffix visible style selected keys)
 221               (setq active nil)
 222               (while (> ilen count)
 223                 (setq keyword (aref item count))
 224                 (setq arg (aref item (1+ count)))
 225                 (setq count (+ 2 count))
 226                 (cond
 227                  ((eq keyword :visible) (setq visible (or arg ''nil)))
 228                  ((eq keyword :key-sequence)
 229                   (setq cache arg cache-specified t))
 230                  ((eq keyword :keys) (setq keys arg no-name nil))
 231                  ((eq keyword :label) (setq label arg))
 232                  ((eq keyword :active) (setq active (or arg ''nil)))
 233                  ((eq keyword :suffix) (setq suffix arg))
 234                  ((eq keyword :style) (setq style arg))
 235                  ((eq keyword :selected) (setq selected (or arg ''nil)))))
 236               (if (stringp suffix)
 237                   (setq label (if (stringp label) (concat label " " suffix)
 238                                 (list 'concat label (concat " " suffix)))))
 239               (if (and selected
 240                        (setq style (assq style easy-menu-button-prefix)))
 241                   (setq prop (cons :button
 242                                    (cons (cons (cdr style) (or selected ''nil))
 243                                          prop))))
 244               (when (stringp keys)
 245                  (if (string-match "^[^\\]*\\(\\\\\\[\\([^]]+\\)]\\)[^\\]*$"
 246                                    keys)
 247                      (let ((prefix
 248                             (if (< (match-beginning 0) (match-beginning 1))
 249                                 (substring keys 0 (match-beginning 1))))
 250                            (postfix
 251                             (if (< (match-end 1) (match-end 0))
 252                                 (substring keys (match-end 1))))
 253                            (cmd (intern (substring keys (match-beginning 2)
 254                                                    (match-end 2)))))
 255                        (setq keys (and (or prefix postfix)
 256                                        (cons prefix postfix)))
 257                        (setq keys
 258                              (and (or keys (not (eq command cmd)))
 259                                   (cons cmd keys))))
 260                    (setq cache-specified nil))
 261                  (if keys (setq prop (cons :keys (cons keys prop)))))
 262               (if (and visible (not (easy-menu-always-true visible)))
 263                   (if (equal visible ''nil)
 264                       ;; Invisible menu item. Don't insert into keymap.
 265                       (setq remove t)
 266                     (setq prop (cons :visible (cons visible prop)))))))
 267         (if (and active (not (easy-menu-always-true active)))
 268             (setq prop (cons :enable (cons active prop))))
 269         (if (and (or no-name cache-specified)
 270                  (or (null cache) (stringp cache) (vectorp cache)))
 271             (setq prop (cons :key-sequence (cons cache prop))))))
 272      (t (error "Invalid menu item in easymenu")))
 273     (easy-menu-define-key menu (if (stringp name) (intern name) name)
 274                           (and (not remove)
 275                                (cons 'menu-item
 276                                      (cons label
 277                                            (and name (cons command prop)))))
 278                           (if (stringp before) (intern before) before))))
 279
 280 (defun easy-menu-define-key (menu key item &optional before)
 281   ;; Add binding in MENU for KEY => ITEM.  Similar to `define-key-after'.
 282   ;; If KEY is not nil then delete any duplications. If ITEM is nil, then
 283   ;; don't insert, only delete.
 284   ;; Optional argument BEFORE is nil or a key in MENU.  If BEFORE is not nil
 285   ;; put binding before BEFORE in MENU, otherwise if binding is already
 286   ;; present in MENU, just change it, otherwise put it last in MENU.
 287   (let ((inserted (null item))          ; Fake already inserted.
 288         tail done)
 289     (while (not done)
 290       (cond
 291        ((or (setq done (or (null (cdr menu)) (keymapp (cdr menu))))
 292             (and before (equal (car-safe (cadr menu)) before)))
 293         ;; If key is nil, stop here, otherwise keep going past the
 294         ;; inserted element so we can delete any duplications that come
 295         ;; later.
 296         (if (null key) (setq done t))
 297         (unless inserted                ; Don't insert more than once.
 298           (setcdr menu (cons (cons key item) (cdr menu)))
 299           (setq inserted t)
 300           (setq menu (cdr menu)))
 301         (setq menu (cdr menu)))
 302        ((and key (equal (car-safe (cadr menu)) key))
 303         (if (or inserted                ; Already inserted or
 304                 (and before             ;  wanted elsewhere and
 305                      (setq tail (cddr menu)) ; not last item and not
 306                      (not (keymapp tail))
 307                      (not (equal (car-safe (car tail)) before)))) ; in position
 308             (setcdr menu (cddr menu))   ; Remove item.
 309           (setcdr (cadr menu) item)     ; Change item.
 310           (setq inserted t)
 311           (setq menu (cdr menu))))
 312        (t (setq menu (cdr menu)))))))
 313
 314 (defun easy-menu-always-true (x)
 315   ;; Return true if X never evaluates to nil.
 316   (if (consp x) (and (eq (car x) 'quote) (cadr x))
 317     (or (eq x t) (not (symbolp x)))))
 318
 319 (defvar easy-menu-item-count 0)
 320
 321 (defun easy-menu-make-symbol (callback)
 322   ;; Return a unique symbol with CALLBACK as function value.
 323   (let ((command
 324          (make-symbol (format "menu-function-%d" easy-menu-item-count))))
 325     (setq easy-menu-item-count (1+ easy-menu-item-count))
 326     (fset command
 327           (if (keymapp callback) callback
 328             `(lambda () (interactive) ,callback)))
 329     command))
 330
 331 ;;;###autoload
 332 (defun easy-menu-change (path name items &optional before)
 333   "Change menu found at PATH as item NAME to contain ITEMS.
 334 PATH is a list of strings for locating the menu containing NAME in the
 335 menu bar.  ITEMS is a list of menu items, as in `easy-menu-define'.
 336 These items entirely replace the previous items in that map.
 337 If NAME is not present in the menu located by PATH, then add item NAME to
 338 that menu. If the optional argument BEFORE is present add NAME in menu
 339 just before BEFORE, otherwise add at end of menu.
 340
 341 Either call this from `menu-bar-update-hook' or use a menu filter,
 342 to implement dynamic menus."
 343   (easy-menu-add-item nil path (cons name items) before))
 344
 345 ;; XEmacs needs the following two functions to add and remove menus.
 346 ;; In Emacs this is done automatically when switching keymaps, so
 347 ;; here easy-menu-remove is a noop and easy-menu-add only precalculates
 348 ;; equivalent keybindings (if easy-menu-precalculate-equivalent-keybindings
 349 ;; is on).
 350 (defun easy-menu-remove (menu))
 351
 352 (defun easy-menu-add (menu &optional map)
 353   "Maybe precalculate equivalent key bindings.
 354 Do it if `easy-menu-precalculate-equivalent-keybindings' is on,"
 355   (when easy-menu-precalculate-equivalent-keybindings
 356     (if (and (symbolp menu) (not (keymapp menu)) (boundp menu))
 357         (setq menu (symbol-value menu)))
 358     (if (keymapp menu) (x-popup-menu nil menu))))
 359
 360 (defun easy-menu-add-item (map path item &optional before)
 361   "At the end of the submenu of MAP with path PATH add ITEM.
 362 If ITEM is already present in this submenu, then this item will be changed.
 363 otherwise ITEM will be added at the end of the submenu, unless the optional
 364 argument BEFORE is present, in which case ITEM will instead be added
 365 before the item named BEFORE.
 366
 367 MAP should normally be a keymap; nil stands for the global menu-bar keymap.
 368 It can also be a symbol, which has earlier been used as the first
 369 argument in a call to `easy-menu-define', or the value of such a symbol.
 370
 371 PATH is a list of strings for locating the submenu where ITEM is to be
 372 added.  If PATH is nil, MAP itself is used.  Otherwise, the first
 373 element should be the name of a submenu directly under MAP.  This
 374 submenu is then traversed recursively with the remaining elements of PATH.
 375 ITEM is either defined as in `easy-menu-define' or a menu defined earlier
 376 by `easy-menu-define' or `easy-menu-create-menu'."
 377   (setq map (easy-menu-get-map map path))
 378   (if (or (keymapp item)
 379           (and (symbolp item) (keymapp (symbol-value item))))
 380       ;; Item is a keymap, find the prompt string and use as item name.
 381       (let ((tail (easy-menu-get-map item nil)) name)
 382         (if (not (keymapp item)) (setq item tail))
 383         (while (and (null name) (consp (setq tail (cdr tail)))
 384                     (not (keymapp tail)))
 385           (if (stringp (car tail)) (setq name (car tail)) ; Got a name.
 386             (setq tail (cdr tail))))
 387         (setq item (cons name item))))
 388   (easy-menu-do-add-item map item before))
 389
 390 (defun easy-menu-item-present-p (map path name)
 391   "In submenu of MAP with path PATH, return true iff item NAME is present.
 392 MAP and PATH are defined as in `easy-menu-add-item'.
 393 NAME should be a string, the name of the element to be looked for."
 394   (lookup-key (easy-menu-get-map map path) (vector (intern name))))
 395
 396 (defun easy-menu-remove-item (map path name)
 397   "From submenu of MAP with path PATH remove item NAME.
 398 MAP and PATH are defined as in `easy-menu-add-item'.
 399 NAME should be a string, the name of the element to be removed."
 400   (easy-menu-define-key (easy-menu-get-map map path) (intern name) nil))
 401
 402 (defun easy-menu-get-map (map path)
 403   ;; Return a sparse keymap in which to add or remove an item.
 404   ;; MAP and PATH are as defined in `easy-menu-add-item'.
 405   (if (null map)
 406       (setq map (or (lookup-key (current-local-map)
 407                                 (vconcat '(menu-bar) (mapcar 'intern path)))
 408                     (lookup-key global-map
 409                                 (vconcat '(menu-bar) (mapcar 'intern path)))
 410                     (let ((new (make-sparse-keymap)))
 411                       (define-key (current-local-map)
 412                         (vconcat '(menu-bar) (mapcar 'intern path)) new)
 413                       new)))
 414     (if (and (symbolp map) (not (keymapp map)))
 415         (setq map (symbol-value map)))
 416     (if path (setq map (lookup-key map (vconcat (mapcar 'intern path))))))
 417   (while (and (symbolp map) (keymapp map))
 418     (setq map (symbol-function map)))
 419   (unless map
 420     (error "Menu specified in easy-menu is not defined"))
 421   (or (keymapp map) (error "Malformed menu in easy-menu: (%s)" map))
 422   map)
 423
 424 (provide 'easymenu)
 425
 426 ;;; easymenu.el ends here