lisp/emacs-lisp/lmenu.el

   1 ;;; lmenu.el --- emulate Lucid's menubar support
   2
   3 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
   4
   5 ;; Keywords: emulations
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Code:
  25
  26 \f
  27 ;; First, emulate the Lucid menubar support in GNU Emacs 19.
  28
  29 ;; Arrange to use current-menubar to set up part of the menu bar.
  30
  31 (defvar current-menubar)
  32
  33 (setq recompute-lucid-menubar 'recompute-lucid-menubar)
  34 (defun recompute-lucid-menubar ()
  35   (define-key lucid-menubar-map [menu-bar]
  36     (condition-case nil
  37         (make-lucid-menu-keymap "menu-bar" current-menubar)
  38       (error (message "Invalid data in current-menubar moved to lucid-failing-menubar")
  39              (sit-for 1)
  40              (setq lucid-failing-menubar current-menubar
  41                    current-menubar nil))))
  42   (setq lucid-menu-bar-dirty-flag nil))
  43
  44 (defvar lucid-menubar-map (make-sparse-keymap))
  45 (or (assq 'current-menubar minor-mode-map-alist)
  46     (setq minor-mode-map-alist
  47           (cons (cons 'current-menubar lucid-menubar-map)
  48                 minor-mode-map-alist)))
  49
  50 (defun set-menubar-dirty-flag ()
  51   (force-mode-line-update)
  52   (setq lucid-menu-bar-dirty-flag t))
  53
  54 (defvar add-menu-item-count 0)
  55
  56 ;; This is a variable whose value is always nil.
  57 (defvar make-lucid-menu-keymap-disable nil)
  58
  59 ;; Return a menu keymap corresponding to a Lucid-style menu list
  60 ;; MENU-ITEMS, and with name MENU-NAME.
  61 (defun make-lucid-menu-keymap (menu-name menu-items)
  62   (let ((menu (make-sparse-keymap menu-name)))
  63     ;; Process items in reverse order,
  64     ;; since the define-key loop reverses them again.
  65     (setq menu-items (reverse menu-items))
  66     (while menu-items
  67       (let ((item (car menu-items))
  68             command name callback)
  69         (cond ((stringp item)
  70                (setq command nil)
  71                (setq name (if (string-match "^-+$" item) "" item)))
  72               ((consp item)
  73                (setq command (make-lucid-menu-keymap (car item) (cdr item)))
  74                (setq name (car item)))
  75               ((vectorp item)
  76                (setq command (make-symbol (format "menu-function-%d"
  77                                                   add-menu-item-count))
  78                      add-menu-item-count (1+ add-menu-item-count)
  79                      name (aref item 0)
  80                      callback (aref item 1))
  81                (if (symbolp callback)
  82                    (fset command callback)
  83                  (fset command (list 'lambda () '(interactive) callback)))
  84                (put command 'menu-alias t)
  85                (let ((i 2))
  86                  (while (< i (length item))
  87                    (cond
  88                     ((eq (aref item i) ':active)
  89                      (put command 'menu-enable
  90                           (or (aref item (1+ i))
  91                               'make-lucid-menu-keymap-disable))
  92                      (setq i (+ 2 i)))
  93                     ((eq (aref item i) ':suffix)
  94                      ;; unimplemented
  95                      (setq i (+ 2 i)))
  96                     ((eq (aref item i) ':keys)
  97                      ;; unimplemented
  98                      (setq i (+ 2 i)))
  99                     ((eq (aref item i) ':style)
 100                      ;; unimplemented
 101                      (setq i (+ 2 i)))
 102                     ((eq (aref item i) ':selected)
 103                      ;; unimplemented
 104                      (setq i (+ 2 i)))
 105                     ((and (symbolp (aref item i))
 106                           (= ?: (string-to-char (symbol-name (aref item i)))))
 107                      (error "Unrecognized menu item keyword: %S"
 108                             (aref item i)))
 109                     ((= i 2)
 110                      ;; old-style format: active-p &optional suffix
 111                      (put command 'menu-enable
 112                           (or (aref item i) 'make-lucid-menu-keymap-disable))
 113                      ;; suffix is unimplemented
 114                      (setq i (length item)))
 115                     (t
 116                      (error "Unexpected menu item value: %S"
 117                             (aref item i))))))))
 118         (if (null command)
 119             ;; Handle inactive strings specially--allow any number
 120             ;; of identical ones.
 121             (setcdr menu (cons (list nil name) (cdr menu)))
 122           (if name
 123               (define-key menu (vector (intern name)) (cons name command)))))
 124       (setq menu-items (cdr menu-items)))
 125     menu))
 126
 127 ;; The value of the cache-symbol for a menu
 128 ;; is
 129 ;;   unbound  --  nothing computed
 130 ;;   (ORIG . TRANSL)
 131 ;;                ORIG is the original menu spec list
 132 ;;                and TRANSL is its translation.
 133
 134 (defmacro popup-menu (arg)
 135   "Pop up the given menu.
 136 A menu is a list of menu items, strings, and submenus.
 137
 138 The first element of a menu must be a string, which is the name of the
 139 menu.  This is the string that will be displayed in the parent menu, if
 140 any.  For toplevel menus, it is ignored.  This string is not displayed
 141 in the menu itself.
 142
 143 A menu item is a vector containing:
 144
 145  - the name of the menu item (a string);
 146  - the `callback' of that item;
 147  - a list of keywords with associated values:
 148    - :active active-p   a form specifying whether this item is selectable;
 149    - :suffix suffix     a string to be appended to the name as an `argument'
 150                         to the command, like `Kill Buffer NAME';
 151    - :keys command-keys a string, suitable for `substitute-command-keys',
 152                         to specify the keyboard equivalent of a command
 153                         when the callback is a form (this is not necessary
 154                         when the callback is a symbol, as the keyboard
 155                         equivalent is computed automatically in that case);
 156    - :style style       a symbol: nil for a normal menu item, `toggle' for
 157                         a toggle button (a single option that can be turned
 158                         on or off), or `radio' for a radio button (one of a
 159                         group of mutually exclusive options);
 160    - :selected form     for `toggle' or `radio' style, a form that specifies
 161                         whether the button will be in the selected state.
 162
 163 Alternately, the vector may contain exactly 3 or 4 elements, with the third
 164 element specifying `active-p' and the fourth specifying `suffix'.
 165
 166 If the `callback' of a menu item is a symbol, then it must name a command.
 167 It will be invoked with `call-interactively'.  If it is a list, then it is
 168 evaluated with `eval'.
 169
 170 If an element of a menu is a string, then that string will be presented in
 171 the menu as unselectable text.
 172
 173 If an element of a menu is a string consisting solely of hyphens, then that
 174 item will be presented as a solid horizontal line.
 175
 176 If an element of a menu is a list, it is treated as a submenu.  The name of
 177 that submenu (the first element in the list) will be used as the name of the
 178 item representing this menu on the parent.
 179
 180 The syntax, more precisely:
 181
 182    form         :=  <something to pass to `eval'>
 183    command      :=  <a symbol or string, to pass to `call-interactively'>
 184    callback     :=  command | form
 185    active-p     :=  <t or nil, whether this thing is selectable>
 186    text         :=  <string, non selectable>
 187    name         :=  <string>
 188    suffix       :=  <string>
 189    command-keys :=  <string>
 190    object-style :=  'nil' | 'toggle' | 'radio'
 191    keyword      :=  ':active' active-p
 192                  |  ':suffix' suffix
 193                  |  ':keys' command-keys
 194                  |  ':style' object-style
 195                  |  ':selected' form
 196    menu-item    :=  '['  name callback active-p [ suffix ]  ']'
 197                  |  '['  name callback [ keyword ]+  ']'
 198    menu         :=  '(' name [ menu-item | menu | text ]+ ')'"
 199   (if (not (symbolp arg))
 200       `(popup-menu-internal ,arg nil)
 201     `(popup-menu-internal ,arg
 202                           ',(intern (concat "popup-menu-" (symbol-name arg))))))
 203
 204 (defun popup-menu-internal (menu cache-symbol)
 205   (if (null cache-symbol)
 206       ;; If no cache symbol, translate the menu afresh each time.
 207       (popup-menu-popup (make-lucid-menu-keymap (car menu) (cdr menu)))
 208     ;; We have a cache symbol.  See if the cache is valid
 209     ;; for the same menu we have now.
 210     (or (and (boundp cache-symbol)
 211              (consp (symbol-value cache-symbol))
 212              (equal (car (symbol-value cache-symbol))
 213                     menu))
 214         ;; If not, update it.
 215         (set cache-symbol
 216              (cons menu (make-lucid-menu-keymap (car menu) (cdr menu)))))
 217     ;; Use the menu in the cache.
 218     (popup-menu-popup (cdr (symbol-value cache-symbol)))))
 219
 220 ;; Pop up MENU-KEYMAP which was made by make-lucid-menu-keymap.
 221 (defun popup-menu-popup (menu-keymap)
 222   (let ((pos (mouse-pixel-position))
 223         answer cmd)
 224     (while (and menu-keymap
 225                 (setq answer (x-popup-menu (list (list (nth 1 pos)
 226                                                        (nthcdr 2 pos))
 227                                                  (car pos))
 228                                            menu-keymap)))
 229       (setq cmd (lookup-key menu-keymap (apply 'vector answer)))
 230       (setq menu-keymap nil)
 231       (and cmd
 232            (if (keymapp cmd)
 233                (setq menu-keymap cmd)
 234              (call-interactively cmd))))))
 235
 236 (defun popup-dialog-box (data)
 237   "Pop up a dialog box.
 238 A dialog box description is a list.
 239
 240  - The first element of the list is a string to display in the dialog box.
 241  - The rest of the elements are descriptions of the dialog box's buttons.
 242    Each one is a vector of three elements:
 243    - The first element is the text of the button.
 244    - The second element is the `callback'.
 245    - The third element is t or nil, whether this button is selectable.
 246
 247 If the `callback' of a button is a symbol, then it must name a command.
 248 It will be invoked with `call-interactively'.  If it is a list, then it is
 249 evaluated with `eval'.
 250
 251 One (and only one) of the buttons may be `nil'.  This marker means that all
 252 following buttons should be flushright instead of flushleft.
 253
 254 The syntax, more precisely:
 255
 256    form         :=  <something to pass to `eval'>
 257    command      :=  <a symbol or string, to pass to `call-interactively'>
 258    callback     :=  command | form
 259    active-p     :=  <t, nil, or a form to evaluate to decide whether this
 260                     button should be selectable>
 261    name         :=  <string>
 262    partition    :=  'nil'
 263    button       :=  '['  name callback active-p ']'
 264    dialog       :=  '(' name [ button ]+ [ partition [ button ]+ ] ')'"
 265   (let ((name (car data))
 266         (tail (cdr data))
 267         converted
 268         choice meaning)
 269     (while tail
 270       (if (null (car tail))
 271           (setq converted (cons nil converted))
 272         (let ((item (aref (car tail) 0))
 273               (callback (aref (car tail) 1))
 274               (enable (aref (car tail) 2)))
 275           (setq converted
 276                 (cons (if enable (cons item callback) item)
 277                       converted))))
 278       (setq tail (cdr tail)))
 279     (setq choice (x-popup-dialog t (cons name (nreverse converted))))
 280     (if choice
 281         (if (symbolp choice)
 282             (call-interactively choice)
 283           (eval choice)))))
 284 \f
 285 ;; This is empty because the usual elements of the menu bar
 286 ;; are provided by menu-bar.el instead.
 287 ;; It would not make sense to duplicate them here.
 288 (defconst default-menubar nil)
 289
 290 (defun set-menubar (menubar)
 291   "Set the default menubar to be menubar."
 292   (setq-default current-menubar (copy-sequence menubar))
 293   (set-menubar-dirty-flag))
 294
 295 (defun set-buffer-menubar (menubar)
 296   "Set the buffer-local menubar to be menubar."
 297   (make-local-variable 'current-menubar)
 298   (setq current-menubar (copy-sequence menubar))
 299   (set-menubar-dirty-flag))
 300
 301 \f
 302 ;;; menu manipulation functions
 303
 304 (defun find-menu-item (menubar item-path-list &optional parent)
 305   "Searches MENUBAR for item given by ITEM-PATH-LIST.
 306 Returns (ITEM . PARENT), where PARENT is the immediate parent of
 307  the item found.
 308 Signals an error if the item is not found."
 309   (or parent (setq item-path-list (mapcar 'downcase item-path-list)))
 310   (if (not (consp menubar))
 311       nil
 312     (let ((rest menubar)
 313           result)
 314       (while rest
 315         (if (and (car rest)
 316                  (equal (car item-path-list)
 317                         (downcase (if (vectorp (car rest))
 318                                       (aref (car rest) 0)
 319                                     (if (stringp (car rest))
 320                                         (car rest)
 321                                       (car (car rest)))))))
 322             (setq result (car rest) rest nil)
 323           (setq rest (cdr rest))))
 324       (if (cdr item-path-list)
 325           (if (consp result)
 326               (find-menu-item (cdr result) (cdr item-path-list) result)
 327             (if result
 328                 (signal 'error (list "not a submenu" result))
 329               (signal 'error (list "no such submenu" (car item-path-list)))))
 330         (cons result parent)))))
 331
 332
 333 (defun disable-menu-item (path)
 334   "Make the named menu item be unselectable.
 335 PATH is a list of strings which identify the position of the menu item in
 336 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 337 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 338 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 339   (let* ((menubar current-menubar)
 340          (pair (find-menu-item menubar path))
 341          (item (car pair))
 342          (menu (cdr pair)))
 343     (or item
 344         (signal 'error (list (if menu "No such menu item" "No such menu")
 345                              path)))
 346     (if (consp item) (error "can't disable menus, only menu items"))
 347     (aset item 2 nil)
 348     (set-menubar-dirty-flag)
 349     item))
 350
 351
 352 (defun enable-menu-item (path)
 353   "Make the named menu item be selectable.
 354 PATH is a list of strings which identify the position of the menu item in
 355 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 356 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 357 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 358   (let* ((menubar current-menubar)
 359          (pair (find-menu-item menubar path))
 360          (item (car pair))
 361          (menu (cdr pair)))
 362     (or item
 363         (signal 'error (list (if menu "No such menu item" "No such menu")
 364                              path)))
 365     (if (consp item) (error "%S is a menu, not a menu item" path))
 366     (aset item 2 t)
 367     (set-menubar-dirty-flag)
 368     item))
 369
 370
 371 (defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before)
 372   (if before (setq before (downcase before)))
 373   (let* ((menubar current-menubar)
 374          (menu (condition-case ()
 375                    (car (find-menu-item menubar menu-path))
 376                  (error nil)))
 377          (item (if (listp menu)
 378                    (car (find-menu-item (cdr menu) (list item-name)))
 379                  (signal 'error (list "not a submenu" menu-path)))))
 380     (or menu
 381         (let ((rest menu-path)
 382               (so-far menubar))
 383           (while rest
 384 ;;;         (setq menu (car (find-menu-item (cdr so-far) (list (car rest)))))
 385             (setq menu
 386                   (if (eq so-far menubar)
 387                       (car (find-menu-item so-far (list (car rest))))
 388                     (car (find-menu-item (cdr so-far) (list (car rest))))))
 389             (or menu
 390                 (let ((rest2 so-far))
 391                   (or rest2
 392                       (error "Trying to modify a menu that doesn't exist"))
 393                   (while (and (cdr rest2) (car (cdr rest2)))
 394                     (setq rest2 (cdr rest2)))
 395                   (setcdr rest2
 396                           (nconc (list (setq menu (list (car rest))))
 397                                  (cdr rest2)))))
 398             (setq so-far menu)
 399             (setq rest (cdr rest)))))
 400     (or menu (setq menu menubar))
 401     (if item
 402         nil     ; it's already there
 403       (if item-p
 404           (setq item (vector item-name item-data enabled-p))
 405         (setq item (cons item-name item-data)))
 406       ;; if BEFORE is specified, try to add it there.
 407       (if before
 408           (setq before (car (find-menu-item menu (list before)))))
 409       (let ((rest menu)
 410             (added-before nil))
 411         (while rest
 412           (if (eq before (car (cdr rest)))
 413               (progn
 414                 (setcdr rest (cons item (cdr rest)))
 415                 (setq rest nil added-before t))
 416             (setq rest (cdr rest))))
 417         (if (not added-before)
 418             ;; adding before the first item on the menubar itself is harder
 419             (if (and (eq menu menubar) (eq before (car menu)))
 420                 (setq menu (cons item menu)
 421                       current-menubar menu)
 422               ;; otherwise, add the item to the end.
 423               (nconc menu (list item))))))
 424     (if item-p
 425         (progn
 426           (aset item 1 item-data)
 427           (aset item 2 (not (null enabled-p))))
 428       (setcar item item-name)
 429       (setcdr item item-data))
 430     (set-menubar-dirty-flag)
 431     item))
 432
 433 (defun add-menu-item (menu-path item-name function enabled-p &optional before)
 434   "Add a menu item to some menu, creating the menu first if necessary.
 435 If the named item exists already, it is changed.
 436 MENU-PATH identifies the menu under which the new menu item should be inserted.
 437  It is a list of strings; for example, (\"File\") names the top-level \"File\"
 438  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
 439 ITEM-NAME is the string naming the menu item to be added.
 440 FUNCTION is the command to invoke when this menu item is selected.
 441  If it is a symbol, then it is invoked with `call-interactively', in the same
 442  way that functions bound to keys are invoked.  If it is a list, then the
 443  list is simply evaluated.
 444 ENABLED-P controls whether the item is selectable or not.
 445 BEFORE, if provided, is the name of a menu item before which this item should
 446  be added, if this item is not on the menu already.  If the item is already
 447  present, it will not be moved."
 448   (or menu-path (error "must specify a menu path"))
 449   (or item-name (error "must specify an item name"))
 450   (add-menu-item-1 t menu-path item-name function enabled-p before))
 451
 452
 453 (defun delete-menu-item (path)
 454   "Remove the named menu item from the menu hierarchy.
 455 PATH is a list of strings which identify the position of the menu item in
 456 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 457 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 458 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 459   (let* ((menubar current-menubar)
 460          (pair (find-menu-item menubar path))
 461          (item (car pair))
 462          (menu (or (cdr pair) menubar)))
 463     (if (not item)
 464         nil
 465       ;; the menubar is the only special case, because other menus begin
 466       ;; with their name.
 467       (if (eq menu current-menubar)
 468           (setq current-menubar (delq item menu))
 469         (delq item menu))
 470       (set-menubar-dirty-flag)
 471       item)))
 472
 473
 474 (defun relabel-menu-item (path new-name)
 475   "Change the string of the specified menu item.
 476 PATH is a list of strings which identify the position of the menu item in
 477 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 478 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 479 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
 480 NEW-NAME is the string that the menu item will be printed as from now on."
 481   (or (stringp new-name)
 482       (setq new-name (signal 'wrong-type-argument (list 'stringp new-name))))
 483   (let* ((menubar current-menubar)
 484          (pair (find-menu-item menubar path))
 485          (item (car pair))
 486          (menu (cdr pair)))
 487     (or item
 488         (signal 'error (list (if menu "No such menu item" "No such menu")
 489                              path)))
 490     (if (and (consp item)
 491              (stringp (car item)))
 492         (setcar item new-name)
 493       (aset item 0 new-name))
 494     (set-menubar-dirty-flag)
 495     item))
 496
 497 (defun add-menu (menu-path menu-name menu-items &optional before)
 498   "Add a menu to the menubar or one of its submenus.
 499 If the named menu exists already, it is changed.
 500 MENU-PATH identifies the menu under which the new menu should be inserted.
 501  It is a list of strings; for example, (\"File\") names the top-level \"File\"
 502  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
 503  If MENU-PATH is nil, then the menu will be added to the menubar itself.
 504 MENU-NAME is the string naming the menu to be added.
 505 MENU-ITEMS is a list of menu item descriptions.
 506  Each menu item should be a vector of three elements:
 507    - a string, the name of the menu item;
 508    - a symbol naming a command, or a form to evaluate;
 509    - and a form whose value determines whether this item is selectable.
 510 BEFORE, if provided, is the name of a menu before which this menu should
 511  be added, if this menu is not on its parent already.  If the menu is already
 512  present, it will not be moved."
 513   (or menu-name (error "must specify a menu name"))
 514   (or menu-items (error "must specify some menu items"))
 515   (add-menu-item-1 nil menu-path menu-name menu-items t before))
 516
 517 \f
 518
 519 (defvar put-buffer-names-in-file-menu t)
 520
 521
 522 ;; Don't unconditionally enable menu bars; leave that up to the user.
 523 ;;(let ((frames (frame-list)))
 524 ;;  (while frames
 525 ;;    (modify-frame-parameters (car frames) '((menu-bar-lines . 1)))
 526 ;;    (setq frames (cdr frames))))
 527 ;;(or (assq 'menu-bar-lines default-frame-alist)
 528 ;;    (setq default-frame-alist
 529 ;;        (cons '(menu-bar-lines . 1) default-frame-alist)))
 530
 531 (set-menubar default-menubar)
 532 \f
 533 (provide 'lmenu)
 534
 535 ;;; lmenu.el ends here