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 obsolete
   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 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 \f
  29 ;; First, emulate the Lucid menubar support in GNU Emacs 19.
  30
  31 ;; Arrange to use current-menubar to set up part of the menu bar.
  32
  33 (defvar current-menubar)
  34
  35 (setq recompute-lucid-menubar 'recompute-lucid-menubar)
  36 (defun recompute-lucid-menubar ()
  37   (define-key lucid-menubar-map [menu-bar]
  38     (condition-case nil
  39         (make-lucid-menu-keymap "menu-bar" current-menubar)
  40       (error (message "Invalid data in current-menubar moved to lucid-failing-menubar")
  41              (sit-for 1)
  42              (setq lucid-failing-menubar current-menubar
  43                    current-menubar nil))))
  44   (setq lucid-menu-bar-dirty-flag nil))
  45
  46 (defvar lucid-menubar-map (make-sparse-keymap))
  47 (or (assq 'current-menubar minor-mode-map-alist)
  48     (setq minor-mode-map-alist
  49           (cons (cons 'current-menubar lucid-menubar-map)
  50                 minor-mode-map-alist)))
  51
  52 ;; XEmacs compatibility
  53 (defun set-menubar-dirty-flag ()
  54   (force-mode-line-update)
  55   (setq lucid-menu-bar-dirty-flag t))
  56
  57 (defvar add-menu-item-count 0)
  58
  59 ;; This is a variable whose value is always nil.
  60 (defvar make-lucid-menu-keymap-disable nil)
  61
  62 ;; Return a menu keymap corresponding to a Lucid-style menu list
  63 ;; MENU-ITEMS, and with name MENU-NAME.
  64 (defun make-lucid-menu-keymap (menu-name menu-items)
  65   (let ((menu (make-sparse-keymap menu-name)))
  66     ;; Process items in reverse order,
  67     ;; since the define-key loop reverses them again.
  68     (setq menu-items (reverse menu-items))
  69     (while menu-items
  70       (let ((item (car menu-items))
  71             command name callback)
  72         (cond ((stringp item)
  73                (setq command nil)
  74                (setq name (if (string-match "^-+$" item) "" item)))
  75               ((consp item)
  76                (setq command (make-lucid-menu-keymap (car item) (cdr item)))
  77                (setq name (car item)))
  78               ((vectorp item)
  79                (setq command (make-symbol (format "menu-function-%d"
  80                                                   add-menu-item-count))
  81                      add-menu-item-count (1+ add-menu-item-count)
  82                      name (aref item 0)
  83                      callback (aref item 1))
  84                (if (symbolp callback)
  85                    (fset command callback)
  86                  (fset command (list 'lambda () '(interactive) callback)))
  87                (put command 'menu-alias t)
  88                (let ((i 2))
  89                  (while (< i (length item))
  90                    (cond
  91                     ((eq (aref item i) ':active)
  92                      (put command 'menu-enable
  93                           (or (aref item (1+ i))
  94                               'make-lucid-menu-keymap-disable))
  95                      (setq i (+ 2 i)))
  96                     ((eq (aref item i) ':suffix)
  97                      ;; unimplemented
  98                      (setq i (+ 2 i)))
  99                     ((eq (aref item i) ':keys)
 100                      ;; unimplemented
 101                      (setq i (+ 2 i)))
 102                     ((eq (aref item i) ':style)
 103                      ;; unimplemented
 104                      (setq i (+ 2 i)))
 105                     ((eq (aref item i) ':selected)
 106                      ;; unimplemented
 107                      (setq i (+ 2 i)))
 108                     ((and (symbolp (aref item i))
 109                           (= ?: (string-to-char (symbol-name (aref item i)))))
 110                      (error "Unrecognized menu item keyword: %S"
 111                             (aref item i)))
 112                     ((= i 2)
 113                      ;; old-style format: active-p &optional suffix
 114                      (put command 'menu-enable
 115                           (or (aref item i) 'make-lucid-menu-keymap-disable))
 116                      ;; suffix is unimplemented
 117                      (setq i (length item)))
 118                     (t
 119                      (error "Unexpected menu item value: %S"
 120                             (aref item i))))))))
 121         (if (null command)
 122             ;; Handle inactive strings specially--allow any number
 123             ;; of identical ones.
 124             (setcdr menu (cons (list nil name) (cdr menu)))
 125           (if name
 126               (define-key menu (vector (intern name)) (cons name command)))))
 127       (setq menu-items (cdr menu-items)))
 128     menu))
 129
 130 ;; XEmacs compatibility function
 131 (defun popup-dialog-box (data)
 132   "Pop up a dialog box.
 133 A dialog box description is a list.
 134
 135  - The first element of the list is a string to display in the dialog box.
 136  - The rest of the elements are descriptions of the dialog box's buttons.
 137    Each one is a vector of three elements:
 138    - The first element is the text of the button.
 139    - The second element is the `callback'.
 140    - The third element is t or nil, whether this button is selectable.
 141
 142 If the `callback' of a button is a symbol, then it must name a command.
 143 It will be invoked with `call-interactively'.  If it is a list, then it is
 144 evaluated with `eval'.
 145
 146 One (and only one) of the buttons may be nil.  This marker means that all
 147 following buttons should be flushright instead of flushleft.
 148
 149 The syntax, more precisely:
 150
 151    form         :=  <something to pass to `eval'>
 152    command      :=  <a symbol or string, to pass to `call-interactively'>
 153    callback     :=  command | form
 154    active-p     :=  <t, nil, or a form to evaluate to decide whether this
 155                     button should be selectable>
 156    name         :=  <string>
 157    partition    :=  'nil'
 158    button       :=  '['  name callback active-p ']'
 159    dialog       :=  '(' name [ button ]+ [ partition [ button ]+ ] ')'"
 160   (let ((name (car data))
 161         (tail (cdr data))
 162         converted
 163         choice meaning)
 164     (while tail
 165       (if (null (car tail))
 166           (setq converted (cons nil converted))
 167         (let ((item (aref (car tail) 0))
 168               (callback (aref (car tail) 1))
 169               (enable (aref (car tail) 2)))
 170           (setq converted
 171                 (cons (if enable (cons item callback) item)
 172                       converted))))
 173       (setq tail (cdr tail)))
 174     (setq choice (x-popup-dialog t (cons name (nreverse converted))))
 175     (if choice
 176         (if (symbolp choice)
 177             (call-interactively choice)
 178           (eval choice)))))
 179 \f
 180 ;; This is empty because the usual elements of the menu bar
 181 ;; are provided by menu-bar.el instead.
 182 ;; It would not make sense to duplicate them here.
 183 (defconst default-menubar nil)
 184
 185 ;; XEmacs compatibility
 186 (defun set-menubar (menubar)
 187   "Set the default menubar to be menubar."
 188   (setq-default current-menubar (copy-sequence menubar))
 189   (set-menubar-dirty-flag))
 190
 191 ;; XEmacs compatibility
 192 (defun set-buffer-menubar (menubar)
 193   "Set the buffer-local menubar to be menubar."
 194   (make-local-variable 'current-menubar)
 195   (setq current-menubar (copy-sequence menubar))
 196   (set-menubar-dirty-flag))
 197
 198 \f
 199 ;;; menu manipulation functions
 200
 201 ;; XEmacs compatibility
 202 (defun find-menu-item (menubar item-path-list &optional parent)
 203   "Searches MENUBAR for item given by ITEM-PATH-LIST.
 204 Returns (ITEM . PARENT), where PARENT is the immediate parent of
 205  the item found.
 206 Signals an error if the item is not found."
 207   (or parent (setq item-path-list (mapcar 'downcase item-path-list)))
 208   (if (not (consp menubar))
 209       nil
 210     (let ((rest menubar)
 211           result)
 212       (while rest
 213         (if (and (car rest)
 214                  (equal (car item-path-list)
 215                         (downcase (if (vectorp (car rest))
 216                                       (aref (car rest) 0)
 217                                     (if (stringp (car rest))
 218                                         (car rest)
 219                                       (car (car rest)))))))
 220             (setq result (car rest) rest nil)
 221           (setq rest (cdr rest))))
 222       (if (cdr item-path-list)
 223           (if (consp result)
 224               (find-menu-item (cdr result) (cdr item-path-list) result)
 225             (if result
 226                 (signal 'error (list "not a submenu" result))
 227               (signal 'error (list "no such submenu" (car item-path-list)))))
 228         (cons result parent)))))
 229
 230
 231 ;; XEmacs compatibility
 232 (defun disable-menu-item (path)
 233   "Make the named menu item be unselectable.
 234 PATH is a list of strings which identify the position of the menu item in
 235 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 236 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 237 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 238   (let* ((menubar current-menubar)
 239          (pair (find-menu-item menubar path))
 240          (item (car pair))
 241          (menu (cdr pair)))
 242     (or item
 243         (signal 'error (list (if menu "No such menu item" "No such menu")
 244                              path)))
 245     (if (consp item) (error "can't disable menus, only menu items"))
 246     (aset item 2 nil)
 247     (set-menubar-dirty-flag)
 248     item))
 249
 250
 251 ;; XEmacs compatibility
 252 (defun enable-menu-item (path)
 253   "Make the named menu item be selectable.
 254 PATH is a list of strings which identify the position of the menu item in
 255 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 256 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 257 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 258   (let* ((menubar current-menubar)
 259          (pair (find-menu-item menubar path))
 260          (item (car pair))
 261          (menu (cdr pair)))
 262     (or item
 263         (signal 'error (list (if menu "No such menu item" "No such menu")
 264                              path)))
 265     (if (consp item) (error "%S is a menu, not a menu item" path))
 266     (aset item 2 t)
 267     (set-menubar-dirty-flag)
 268     item))
 269
 270
 271 (defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before)
 272   (if before (setq before (downcase before)))
 273   (let* ((menubar current-menubar)
 274          (menu (condition-case ()
 275                    (car (find-menu-item menubar menu-path))
 276                  (error nil)))
 277          (item (if (listp menu)
 278                    (car (find-menu-item (cdr menu) (list item-name)))
 279                  (signal 'error (list "not a submenu" menu-path)))))
 280     (or menu
 281         (let ((rest menu-path)
 282               (so-far menubar))
 283           (while rest
 284 ;;;         (setq menu (car (find-menu-item (cdr so-far) (list (car rest)))))
 285             (setq menu
 286                   (if (eq so-far menubar)
 287                       (car (find-menu-item so-far (list (car rest))))
 288                     (car (find-menu-item (cdr so-far) (list (car rest))))))
 289             (or menu
 290                 (let ((rest2 so-far))
 291                   (or rest2
 292                       (error "Trying to modify a menu that doesn't exist"))
 293                   (while (and (cdr rest2) (car (cdr rest2)))
 294                     (setq rest2 (cdr rest2)))
 295                   (setcdr rest2
 296                           (nconc (list (setq menu (list (car rest))))
 297                                  (cdr rest2)))))
 298             (setq so-far menu)
 299             (setq rest (cdr rest)))))
 300     (or menu (setq menu menubar))
 301     (if item
 302         nil     ; it's already there
 303       (if item-p
 304           (setq item (vector item-name item-data enabled-p))
 305         (setq item (cons item-name item-data)))
 306       ;; if BEFORE is specified, try to add it there.
 307       (if before
 308           (setq before (car (find-menu-item menu (list before)))))
 309       (let ((rest menu)
 310             (added-before nil))
 311         (while rest
 312           (if (eq before (car (cdr rest)))
 313               (progn
 314                 (setcdr rest (cons item (cdr rest)))
 315                 (setq rest nil added-before t))
 316             (setq rest (cdr rest))))
 317         (if (not added-before)
 318             ;; adding before the first item on the menubar itself is harder
 319             (if (and (eq menu menubar) (eq before (car menu)))
 320                 (setq menu (cons item menu)
 321                       current-menubar menu)
 322               ;; otherwise, add the item to the end.
 323               (nconc menu (list item))))))
 324     (if item-p
 325         (progn
 326           (aset item 1 item-data)
 327           (aset item 2 (not (null enabled-p))))
 328       (setcar item item-name)
 329       (setcdr item item-data))
 330     (set-menubar-dirty-flag)
 331     item))
 332
 333 ;; XEmacs compatibility
 334 (defun add-menu-item (menu-path item-name function enabled-p &optional before)
 335   "Add a menu item to some menu, creating the menu first if necessary.
 336 If the named item exists already, it is changed.
 337 MENU-PATH identifies the menu under which the new menu item should be inserted.
 338  It is a list of strings; for example, (\"File\") names the top-level \"File\"
 339  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
 340 ITEM-NAME is the string naming the menu item to be added.
 341 FUNCTION is the command to invoke when this menu item is selected.
 342  If it is a symbol, then it is invoked with `call-interactively', in the same
 343  way that functions bound to keys are invoked.  If it is a list, then the
 344  list is simply evaluated.
 345 ENABLED-P controls whether the item is selectable or not.
 346 BEFORE, if provided, is the name of a menu item before which this item should
 347  be added, if this item is not on the menu already.  If the item is already
 348  present, it will not be moved."
 349   (or menu-path (error "must specify a menu path"))
 350   (or item-name (error "must specify an item name"))
 351   (add-menu-item-1 t menu-path item-name function enabled-p before))
 352
 353
 354 ;; XEmacs compatibility
 355 (defun delete-menu-item (path)
 356   "Remove the named menu item from the menu hierarchy.
 357 PATH is a list of strings which identify the position of the menu item in
 358 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 359 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 360 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 361   (let* ((menubar current-menubar)
 362          (pair (find-menu-item menubar path))
 363          (item (car pair))
 364          (menu (or (cdr pair) menubar)))
 365     (if (not item)
 366         nil
 367       ;; the menubar is the only special case, because other menus begin
 368       ;; with their name.
 369       (if (eq menu current-menubar)
 370           (setq current-menubar (delq item menu))
 371         (delq item menu))
 372       (set-menubar-dirty-flag)
 373       item)))
 374
 375
 376 ;; XEmacs compatibility
 377 (defun relabel-menu-item (path new-name)
 378   "Change the string of the specified menu item.
 379 PATH is a list of strings which identify the position of the menu item in
 380 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 381 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 382 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
 383 NEW-NAME is the string that the menu item will be printed as from now on."
 384   (or (stringp new-name)
 385       (setq new-name (signal 'wrong-type-argument (list 'stringp new-name))))
 386   (let* ((menubar current-menubar)
 387          (pair (find-menu-item menubar path))
 388          (item (car pair))
 389          (menu (cdr pair)))
 390     (or item
 391         (signal 'error (list (if menu "No such menu item" "No such menu")
 392                              path)))
 393     (if (and (consp item)
 394              (stringp (car item)))
 395         (setcar item new-name)
 396       (aset item 0 new-name))
 397     (set-menubar-dirty-flag)
 398     item))
 399
 400 ;; XEmacs compatibility
 401 (defun add-menu (menu-path menu-name menu-items &optional before)
 402   "Add a menu to the menubar or one of its submenus.
 403 If the named menu exists already, it is changed.
 404 MENU-PATH identifies the menu under which the new menu should be inserted.
 405  It is a list of strings; for example, (\"File\") names the top-level \"File\"
 406  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
 407  If MENU-PATH is nil, then the menu will be added to the menubar itself.
 408 MENU-NAME is the string naming the menu to be added.
 409 MENU-ITEMS is a list of menu item descriptions.
 410  Each menu item should be a vector of three elements:
 411    - a string, the name of the menu item;
 412    - a symbol naming a command, or a form to evaluate;
 413    - and a form whose value determines whether this item is selectable.
 414 BEFORE, if provided, is the name of a menu before which this menu should
 415  be added, if this menu is not on its parent already.  If the menu is already
 416  present, it will not be moved."
 417   (or menu-name (error "must specify a menu name"))
 418   (or menu-items (error "must specify some menu items"))
 419   (add-menu-item-1 nil menu-path menu-name menu-items t before))
 420
 421 \f
 422
 423 (defvar put-buffer-names-in-file-menu t)
 424
 425
 426 ;; Don't unconditionally enable menu bars; leave that up to the user.
 427 ;;(let ((frames (frame-list)))
 428 ;;  (while frames
 429 ;;    (modify-frame-parameters (car frames) '((menu-bar-lines . 1)))
 430 ;;    (setq frames (cdr frames))))
 431 ;;(or (assq 'menu-bar-lines default-frame-alist)
 432 ;;    (setq default-frame-alist
 433 ;;        (cons '(menu-bar-lines . 1) default-frame-alist)))
 434
 435 (set-menubar default-menubar)
 436 \f
 437 (provide 'lmenu)
 438
 439 ;;; arch-tag: 7051c396-2837-435a-ae11-b2d2e2af8fc1
 440 ;;; lmenu.el ends here