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

   1 ;;; lmenu.el --- emulate Lucid's menubar support
   2
   3 ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 ;;; Code:
  22
  23 \f
  24 ;; First, emulate the Lucid menubar support in GNU Emacs 19.
  25
  26 ;; Arrange to use current-menubar to set up part of the menu bar.
  27
  28 (setq recompute-lucid-menubar 'recompute-lucid-menubar)
  29 (defun recompute-lucid-menubar ()
  30   (define-key lucid-menubar-map [menu-bar]
  31     (condition-case nil
  32         (make-lucid-menu-keymap "menu-bar" current-menubar)
  33       (error (message "Invalid data in current-menubar moved to lucid-failing-menubar")
  34              (sit-for 1)
  35              (setq lucid-failing-menubar current-menubar
  36                    current-menubar nil))))
  37   (setq lucid-menu-bar-dirty-flag nil))
  38
  39 (defvar lucid-menubar-map (make-sparse-keymap))
  40 (or (assq 'current-menubar minor-mode-map-alist)
  41     (setq minor-mode-map-alist
  42           (cons (cons 'current-menubar lucid-menubar-map)
  43                 minor-mode-map-alist)))
  44
  45 (defun set-menubar-dirty-flag ()
  46   (force-mode-line-update)
  47   (setq lucid-menu-bar-dirty-flag t))
  48
  49 (defvar add-menu-item-count 0)
  50
  51 ;; Return a menu keymap corresponding to a Lucid-style menu list
  52 ;; MENU-ITEMS, and with name MENU-NAME.
  53 (defun make-lucid-menu-keymap (menu-name menu-items)
  54   (let ((menu (make-sparse-keymap menu-name)))
  55     ;; Process items in reverse order,
  56     ;; since the define-key loop reverses them again.
  57     (setq menu-items (reverse menu-items))
  58     (while menu-items
  59       (let* ((item (car menu-items))
  60              (callback (if (vectorp item) (aref item 1)))
  61              command enabler name)
  62         (cond ((stringp item)
  63                (setq command nil)
  64                (setq name item))
  65               ((consp item)
  66                (setq command (make-lucid-menu-keymap (car item) (cdr item)))
  67                (setq name (car item)))
  68               ((vectorp item)
  69                (setq command (make-symbol (format "menu-function-%d"
  70                                                   add-menu-item-count)))
  71                (setq enabler (make-symbol (format "menu-function-%d-enabler"
  72                                                   add-menu-item-count)))
  73                (setq add-menu-item-count (1+ add-menu-item-count))
  74                (put command 'menu-enable enabler)
  75                (set enabler (aref item 2))
  76                (setq name (aref item 0))
  77                (if (symbolp callback)
  78                    (fset command callback)
  79                  (fset command (list 'lambda () '(interactive) callback)))))
  80         (if name
  81             (define-key menu (vector (intern name)) (cons name command))))
  82       (setq menu-items (cdr menu-items)))
  83     menu))
  84
  85 (defun popup-menu (menu-desc)
  86   "Pop up the given menu.
  87 A menu is a list of menu items, strings, and submenus.
  88
  89 The first element of a menu must be a string, which is the name of the
  90 menu.  This is the string that will be displayed in the parent menu, if
  91 any.  For toplevel menus, it is ignored.  This string is not displayed
  92 in the menu itself.
  93
  94 A menu item is a vector of three or four elements:
  95
  96  - the name of the menu item (a string);
  97  - the `callback' of that item;
  98  - whether this item is active (selectable);
  99  - and an optional string to append to the name.
 100
 101 If the `callback' of a menu item is a symbol, then it must name a command.
 102 It will be invoked with `call-interactively'.  If it is a list, then it is
 103 evaluated with `eval'.
 104
 105 The fourth element of a menu item is a convenient way of adding the name
 106 of a command's ``argument'' to the menu, like ``Kill Buffer NAME''.
 107
 108 If an element of a menu is a string, then that string will be presented in
 109 the menu as unselectable text.
 110
 111 If an element of a menu is a string consisting solely of hyphens, then that
 112 item will be presented as a solid horizontal line.
 113
 114 If an element of a menu is a list, it is treated as a submenu.  The name of
 115 that submenu (the first element in the list) will be used as the name of the
 116 item representing this menu on the parent.
 117
 118 The syntax, more precisely:
 119
 120    form         :=  <something to pass to `eval'>
 121    command      :=  <a symbol or string, to pass to `call-interactively'>
 122    callback     :=  command | form
 123    active-p     :=  <t or nil, whether this thing is selectable>
 124    text         :=  <string, non selectable>
 125    name         :=  <string>
 126    argument     :=  <string>
 127    menu-item    :=  '['  name callback active-p [ argument ]  ']'
 128    menu         :=  '(' name [ menu-item | menu | text ]+ ')'
 129 "
 130   (let ((menu (make-lucid-menu-keymap (car menu-desc) (cdr menu-desc)))
 131         (pos (mouse-position))
 132         answer)
 133     (setq answer (x-popup-menu (list (list (nth 1 pos) (nthcdr 2 pos))
 134                                      (car pos))
 135                                menu))
 136     (setq cmd (lookup-key menu (vector answer)))
 137     (if cmd (call-interactively cmd))))
 138 \f
 139 (defconst default-menubar
 140   '(("File"     ["New Frame"            x-new-frame             t]
 141                 ["Open File..."         find-file               t]
 142                 ["Save Buffer"          save-buffer             t  nil]
 143                 ["Save Buffer As..."    write-file              t]
 144                 ["Revert Buffer"        revert-buffer           t  nil]
 145                 "-----"
 146                 ["Print Buffer"         lpr-buffer              t  nil]
 147                 "-----"
 148                 ["Delete Frame"         delete-frame            t]
 149 ;;              ["Kill Buffer..."       kill-buffer             t]
 150                 ["Kill Buffer"          kill-this-buffer        t  nil]
 151                 ["Exit Emacs"           save-buffers-kill-emacs t]
 152                 )
 153     ("Edit"     ["Undo"                 advertised-undo            t]
 154                 ["Cut"                  x-kill-primary-selection   t]
 155                 ["Copy"                 x-copy-primary-selection   t]
 156                 ["Paste"                x-yank-clipboard-selection t]
 157                 ["Clear"                x-delete-primary-selection t]
 158                 )
 159     ("Buffers"  "")
 160
 161     nil         ; the partition: menus after this are flushright
 162
 163     ("Help"     ["Info"                 info                    t]
 164                 ["Describe Mode"        describe-mode           t]
 165                 ["Command Apropos..."   command-apropos         t]
 166                 ["List Keybindings"     describe-bindings       t]
 167                 ["Describe Key..."      describe-key            t]
 168                 ["Describe Function..." describe-function       t]
 169                 ["Describe Variable..." describe-variable       t]
 170                 "-----"
 171                 ["Man..."               manual-entry            t]
 172                 ["Emacs Tutorial"       help-with-tutorial      t]
 173                 ["Emacs News"           view-emacs-news         t]
 174                 )
 175     ))
 176
 177
 178 (defun kill-this-buffer ()      ; for the menubar
 179   "Kills the current buffer."
 180   (interactive)
 181   (kill-buffer (current-buffer)))
 182
 183 (defun x-new-frame (&optional frame-name)
 184   "Creates a new Emacs frame (that is, a new X window.)"
 185   (interactive)
 186   (select-frame (x-create-frame
 187                   (append (if frame-name
 188                               (list (cons 'name frame-name))
 189                             nil)
 190                           frame-default-alist)))
 191   (switch-to-buffer (get-buffer-create "*scratch*"))
 192   )
 193
 194 (defun set-menubar (menubar)
 195   "Set the default menubar to be menubar."
 196   (setq-default current-menubar (copy-sequence menubar))
 197   (set-menubar-dirty-flag))
 198
 199 (defun set-buffer-menubar (menubar)
 200   "Set the buffer-local menubar to be menubar."
 201   (make-local-variable 'current-menubar)
 202   (setq current-menubar (copy-sequence menubar))
 203   (set-menubar-dirty-flag))
 204
 205 \f
 206 ;;; menu manipulation functions
 207
 208 (defun find-menu-item (menubar item-path-list &optional parent)
 209   "Searches MENUBAR for item given by ITEM-PATH-LIST.
 210 Returns (ITEM . PARENT), where PARENT is the immediate parent of
 211  the item found.
 212 Signals an error if the item is not found."
 213   (or parent (setq item-path-list (mapcar 'downcase item-path-list)))
 214   (if (not (consp menubar))
 215       nil
 216     (let ((rest menubar)
 217           result)
 218       (while rest
 219         (if (and (car rest)
 220                  (equal (car item-path-list)
 221                         (downcase (if (vectorp (car rest))
 222                                       (aref (car rest) 0)
 223                                     (if (stringp (car rest))
 224                                         (car rest)
 225                                       (car (car rest)))))))
 226             (setq result (car rest) rest nil)
 227           (setq rest (cdr rest))))
 228       (if (cdr item-path-list)
 229           (if (consp result)
 230               (find-menu-item (cdr result) (cdr item-path-list) result)
 231             (if result
 232                 (signal 'error (list "not a submenu" result))
 233               (signal 'error (list "no such submenu" (car item-path-list)))))
 234         (cons result parent)))))
 235
 236
 237 (defun disable-menu-item (path)
 238   "Make the named menu item be unselectable.
 239 PATH is a list of strings which identify the position of the menu item in
 240 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 241 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 242 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 243   (let* ((menubar current-menubar)
 244          (pair (find-menu-item menubar path))
 245          (item (car pair))
 246          (menu (cdr pair)))
 247     (or item
 248         (signal 'error (list (if menu "No such menu item" "No such menu")
 249                              path)))
 250     (if (consp item) (error "can't disable menus, only menu items"))
 251     (aset item 2 nil)
 252     (set-menubar-dirty-flag)
 253     item))
 254
 255
 256 (defun enable-menu-item (path)
 257   "Make the named menu item be selectable.
 258 PATH is a list of strings which identify the position of the menu item in
 259 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 260 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 261 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
 262   (let* ((menubar current-menubar)
 263          (pair (find-menu-item menubar path))
 264          (item (car pair))
 265          (menu (cdr pair)))
 266     (or item
 267         (signal 'error (list (if menu "No such menu item" "No such menu")
 268                              path)))
 269     (if (consp item) (error "%S is a menu, not a menu item" path))
 270     (aset item 2 t)
 271     (set-menubar-dirty-flag)
 272     item))
 273
 274
 275 (defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before)
 276   (if before (setq before (downcase before)))
 277   (let* ((menubar current-menubar)
 278          (menu (condition-case ()
 279                    (car (find-menu-item menubar menu-path))
 280                  (error nil)))
 281          (item (if (listp menu)
 282                    (car (find-menu-item (cdr menu) (list item-name)))
 283                  (signal 'error (list "not a submenu" menu-path)))))
 284     (or menu
 285         (let ((rest menu-path)
 286               (so-far menubar))
 287           (while rest
 288 ;;;         (setq menu (car (find-menu-item (cdr so-far) (list (car rest)))))
 289             (setq menu
 290                   (if (eq so-far menubar)
 291                       (car (find-menu-item so-far (list (car rest))))
 292                     (car (find-menu-item (cdr so-far) (list (car rest))))))
 293             (or menu
 294                 (let ((rest2 so-far))
 295                   (while (and (cdr rest2) (car (cdr rest2)))
 296                     (setq rest2 (cdr rest2)))
 297                   (setcdr rest2
 298                   (nconc (list (setq menu (list (car rest))))
 299                          (cdr rest2)))))
 300             (setq so-far menu)
 301             (setq rest (cdr rest)))))
 302     (or menu (setq menu menubar))
 303     (if item
 304         nil     ; it's already there
 305       (if item-p
 306           (setq item (vector item-name item-data enabled-p))
 307         (setq item (cons item-name item-data)))
 308       ;; if BEFORE is specified, try to add it there.
 309       (if before
 310           (setq before (car (find-menu-item menu (list before)))))
 311       (let ((rest menu)
 312             (added-before nil))
 313         (while rest
 314           (if (eq before (car (cdr rest)))
 315               (progn
 316                 (setcdr rest (cons item (cdr rest)))
 317                 (setq rest nil added-before t))
 318             (setq rest (cdr rest))))
 319         (if (not added-before)
 320             ;; adding before the first item on the menubar itself is harder
 321             (if (and (eq menu menubar) (eq before (car menu)))
 322                 (setq menu (cons item menu)
 323                       current-menubar menu)
 324               ;; otherwise, add the item to the end.
 325               (nconc menu (list item))))))
 326     (if item-p
 327         (progn
 328           (aset item 1 item-data)
 329           (aset item 2 (not (null enabled-p))))
 330       (setcar item item-name)
 331       (setcdr item item-data))
 332     (set-menubar-dirty-flag)
 333     item))
 334
 335 (defun add-menu-item (menu-path item-name function enabled-p &optional before)
 336   "Add a menu item to some menu, creating the menu first if necessary.
 337 If the named item exists already, it is changed.
 338 MENU-PATH identifies the menu under which the new menu item should be inserted.
 339  It is a list of strings; for example, (\"File\") names the top-level \"File\"
 340  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
 341 ITEM-NAME is the string naming the menu item to be added.
 342 FUNCTION is the command to invoke when this menu item is selected.
 343  If it is a symbol, then it is invoked with `call-interactively', in the same
 344  way that functions bound to keys are invoked.  If it is a list, then the
 345  list is simply evaluated.
 346 ENABLED-P controls whether the item is selectable or not.
 347 BEFORE, if provided, is the name of a menu item before which this item should
 348  be added, if this item is not on the menu already.  If the item is already
 349  present, it will not be moved."
 350   (or menu-path (error "must specify a menu path"))
 351   (or item-name (error "must specify an item name"))
 352   (add-menu-item-1 t menu-path item-name function enabled-p before))
 353
 354
 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 (defun relabel-menu-item (path new-name)
 377   "Change the string of the specified menu item.
 378 PATH is a list of strings which identify the position of the menu item in
 379 the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
 380 under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the
 381 menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
 382 NEW-NAME is the string that the menu item will be printed as from now on."
 383   (or (stringp new-name)
 384       (setq new-name (signal 'wrong-type-argument (list 'stringp new-name))))
 385   (let* ((menubar current-menubar)
 386          (pair (find-menu-item menubar path))
 387          (item (car pair))
 388          (menu (cdr pair)))
 389     (or item
 390         (signal 'error (list (if menu "No such menu item" "No such menu")
 391                              path)))
 392     (if (and (consp item)
 393              (stringp (car item)))
 394         (setcar item new-name)
 395       (aset item 0 new-name))
 396     (set-menubar-dirty-flag)
 397     item))
 398
 399 (defun add-menu (menu-path menu-name menu-items &optional before)
 400   "Add a menu to the menubar or one of its submenus.
 401 If the named menu exists already, it is changed.
 402 MENU-PATH identifies the menu under which the new menu should be inserted.
 403  It is a list of strings; for example, (\"File\") names the top-level \"File\"
 404  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
 405  If MENU-PATH is nil, then the menu will be added to the menubar itself.
 406 MENU-NAME is the string naming the menu to be added.
 407 MENU-ITEMS is a list of menu item descriptions.
 408  Each menu item should be a vector of three elements:
 409    - a string, the name of the menu item;
 410    - a symbol naming a command, or a form to evaluate;
 411    - and t or nil, whether this item is selectable.
 412 BEFORE, if provided, is the name of a menu before which this menu should
 413  be added, if this menu is not on its parent already.  If the menu is already
 414  present, it will not be moved."
 415   (or menu-name (error "must specify a menu name"))
 416   (or menu-items (error "must specify some menu items"))
 417   (add-menu-item-1 nil menu-path menu-name menu-items t before))
 418
 419 \f
 420
 421 (defvar put-buffer-names-in-file-menu t)
 422
 423 (defun sensitize-file-and-edit-menus-hook ()
 424   "For use as a value of activate-menubar-hook.
 425 This function changes the sensitivity of these File and Edit menu items:
 426
 427   Cut    sensitive only when emacs owns the primary X Selection.
 428   Copy   sensitive only when emacs owns the primary X Selection.
 429   Clear  sensitive only when emacs owns the primary X Selection.
 430   Paste  sensitive only when there is an owner for the X Clipboard Selection.
 431   Undo   sensitive only when there is undo information.
 432          While in the midst of an undo, this is changed to \"Undo More\".
 433
 434   Kill Buffer    has the name of the current buffer appended to it.
 435   Print Buffer   has the name of the current buffer appended to it.
 436   Save Buffer    has the name of the current buffer appended to it, and is
 437                  sensitive only when the current buffer is modified.
 438   Revert Buffer  has the name of the current buffer appended to it, and is
 439                  sensitive only when the current buffer has a file.
 440   Delete Frame   sensitive only when there is more than one visible frame."
 441   ;;
 442   ;; the hair in here to not update the menubar unless something has changed
 443   ;; isn't really necessary (the menubar code is fast enough) but it makes
 444   ;; me feel better (and creates marginally less list garbage.)
 445   (let* ((file-menu (cdr (car (find-menu-item current-menubar '("File")))))
 446          (edit-menu (cdr (car (find-menu-item current-menubar '("Edit")))))
 447          (save  (car (find-menu-item file-menu '("Save Buffer"))))
 448          (rvt   (car (find-menu-item file-menu '("Revert Buffer"))))
 449          (del   (car (find-menu-item file-menu '("Delete Frame"))))
 450          (print (car (find-menu-item file-menu '("Print Buffer"))))
 451          (kill  (car (find-menu-item file-menu '("Kill Buffer"))))
 452          (cut   (car (find-menu-item edit-menu '("Cut"))))
 453          (copy  (car (find-menu-item edit-menu '("Copy"))))
 454          (paste (car (find-menu-item edit-menu '("Paste"))))
 455          (clear (car (find-menu-item edit-menu '("Clear"))))
 456          (undo  (or (car (find-menu-item edit-menu '("Undo")))
 457                     (car (find-menu-item edit-menu '("Undo More")))))
 458          (name (buffer-name))
 459          (emacs-owns-selection-p (x-selection-owner-p))
 460          (clipboard-exists-p (x-selection-exists-p 'CLIPBOARD))
 461          undo-available undoing-more
 462          (undo-info-available (not (null (and (not (eq t buffer-undo-list))
 463                                    (if (eq last-command 'undo)
 464                                        (setq undoing-more
 465                                              (and (boundp 'pending-undo-list)
 466                                             pending-undo-list)
 467                                      buffer-undo-list))))))
 468          undo-name undo-state
 469          (change-p
 470           (or (and cut   (not (eq emacs-owns-selection-p (aref cut 2))))
 471               (and copy  (not (eq emacs-owns-selection-p (aref copy 2))))
 472               (and clear (not (eq emacs-owns-selection-p (aref clear 2))))
 473               (and paste (not (eq clipboard-exists-p (aref paste 2))))
 474               (and save  (not (eq (buffer-modified-p) (aref save 2))))
 475               (and rvt   (not (eq (not (not buffer-file-name)) (aref rvt 2))))
 476               (and del   (not (eq (null (cdr (visible-frame-list))) (aref del 2))))
 477               )))
 478     (if (not put-buffer-names-in-file-menu)
 479         nil
 480       (if (= (length save)  4) (progn (aset save  3 name) (setq change-p t)))
 481       (if (= (length rvt)   4) (progn (aset rvt   3 name) (setq change-p t)))
 482       (if (= (length print) 4) (progn (aset print 3 name) (setq change-p t)))
 483       (if (= (length kill)  4) (progn (aset kill  3 name) (setq change-p t))))
 484     (if save  (aset save  2 (buffer-modified-p)))
 485     (if rvt   (aset rvt   2 (not (not buffer-file-name))))
 486     (if del   (aset del   2 (null (cdr (visible-frame-list)))))
 487     (if cut   (aset cut   2 emacs-owns-selection-p))
 488     (if copy  (aset copy  2 emacs-owns-selection-p))
 489     (if clear (aset clear 2 emacs-owns-selection-p))
 490     (if paste (aset paste 2 clipboard-exists-p))
 491
 492     ;; we could also do this with the third field of the item.
 493     (if (eq last-command 'undo)
 494         (setq undo-name "Undo More"
 495               undo-state (not (null (and (boundp 'pending-undo-list)
 496                                          pending-undo-list))))
 497       (setq undo-name "Undo"
 498             undo-state (and (not (eq buffer-undo-list t))
 499                             (not (null
 500                                   (or buffer-undo-list
 501                                       (and (boundp 'pending-undo-list)
 502                                            pending-undo-list)))))))
 503     (if buffer-read-only (setq undo-state nil))
 504     (if (and undo
 505              (or (not (equal undo-name (aref undo 0)))
 506                  (not (eq undo-state (aref undo 2)))))
 507         (progn (aset undo 0 undo-name)
 508                (aset undo 2 undo-state)
 509                (setq change-p t)))
 510     ;; if we made any changes, return nil
 511     ;; otherwise return t to indicate that we haven't done anything.
 512     (not change-p)))
 513
 514 ;; this version is too slow
 515 (defun format-buffers-menu-line (buffer)
 516   "Returns a string to represent the given buffer in the Buffer menu.
 517 nil means the buffer shouldn't be listed.  You can redefine this."
 518   (if (string-match "\\` " (buffer-name buffer))
 519       nil
 520     (save-excursion
 521      (set-buffer buffer)
 522      (let ((size (buffer-size)))
 523        (format "%s%s %-19s %6s %-15s %s"
 524                (if (buffer-modified-p) "*" " ")
 525                (if buffer-read-only "%" " ")
 526                (buffer-name)
 527                size
 528                mode-name
 529                (or (buffer-file-name) ""))))))
 530
 531 (defun format-buffers-menu-line (buffer)
 532   (if (string-match "\\` " (setq buffer (buffer-name buffer)))
 533       nil
 534     buffer))
 535
 536 (defvar buffers-menu-max-size 10
 537   "*Maximum number of entries which may appear on the \"Buffers\" menu.
 538 If this is 10, then only the ten most-recently-selected buffers will be
 539 shown.  If this is nil, then all buffers will be shown.  Setting this to
 540 a large number or nil will slow down menu responsiveness.")
 541
 542 (defvar complex-buffers-menu-p nil
 543   "*If true, the buffers menu will contain several commands, as submenus
 544 of each buffer line.  If this is false, then there will be only one command:
 545 select that buffer.")
 546
 547 (defvar buffers-menu-switch-to-buffer-function 'switch-to-buffer
 548   "*The function to call to select a buffer from the buffers menu.
 549 `switch-to-buffer' is a good choice, as is `pop-to-buffer'.")
 550
 551
 552 (defun buffer-menu-save-buffer (buffer)
 553   (save-excursion
 554     (set-buffer buffer)
 555     (save-buffer)))
 556
 557 (defun buffer-menu-write-file (buffer)
 558   (save-excursion
 559     (set-buffer buffer)
 560     (write-file (read-file-name
 561                  (concat "Write " (buffer-name (current-buffer))
 562                          " to file: ")))))
 563
 564
 565 (defsubst build-buffers-menu-internal (buffers)
 566   (let (name line)
 567     (mapcar
 568      (if complex-buffers-menu-p
 569          (function
 570           (lambda (buffer)
 571             (if (setq line (format-buffers-menu-line buffer))
 572                 (list line
 573                       (vector "Switch to Buffer"
 574                               (list buffers-menu-switch-to-buffer-function
 575                                     (setq name (buffer-name buffer)))
 576                               t)
 577                       (if (and (buffer-modified-p buffer)
 578                                (buffer-file-name buffer))
 579                           (vector "Save Buffer"
 580                                   (list 'buffer-menu-save-buffer name) t)
 581                         ["Save Buffer" nil nil])
 582                       (vector "Save Buffer As..."
 583                               (list 'buffer-menu-write-file name) t)
 584                       (vector "Kill Buffer" (list 'kill-buffer name) t)))))
 585        (function (lambda (buffer)
 586                    (if (setq line (format-buffers-menu-line buffer))
 587                        (vector line
 588                                (list buffers-menu-switch-to-buffer-function
 589                                      (buffer-name buffer))
 590                                t)))))
 591      buffers)))
 592
 593 (defun build-buffers-menu-hook ()
 594   "For use as a value of activate-menubar-hook.
 595 This function changes the contents of the \"Buffers\" menu to correspond
 596 to the current set of buffers.  Only the most-recently-used few buffers
 597 will be listed on the menu, for efficiency reasons.  You can control how
 598 many buffers will be shown by setting `buffers-menu-max-size'.
 599 You can control the text of the menu items by redefining the function
 600 `format-buffers-menu-line'."
 601   (let ((buffer-menu (car (find-menu-item current-menubar '("Buffers"))))
 602         name
 603         buffers)
 604     (if (not buffer-menu)
 605         nil
 606       (setq buffers (buffer-list))
 607
 608       (if (and (integerp buffers-menu-max-size)
 609                (> buffers-menu-max-size 1))
 610           (if (> (length buffers) buffers-menu-max-size)
 611               (setcdr (nthcdr buffers-menu-max-size buffers) nil)))
 612
 613       (setq buffers (build-buffers-menu-internal buffers))
 614       (setq buffers (nconc (delq nil buffers)
 615                            '("----" ["List All Buffers" list-buffers t])))
 616       ;; slightly (only slightly) more efficient to not install the menubar
 617       ;; if it hasn't visibly changed.
 618       (if (equal buffers (cdr buffer-menu))
 619           t  ; return t meaning "no change"
 620         (setcdr buffer-menu buffers)
 621         (set-menubar-dirty-flag)
 622         nil))))
 623
 624 (add-hook 'activate-menubar-hook 'build-buffers-menu-hook)
 625 (add-hook 'activate-menubar-hook 'sensitize-file-and-edit-menus-hook)
 626
 627 (let ((frames (frame-list)))
 628   (while frames
 629     (modify-frame-parameters (car frames) '((menu-bar-lines . 1)))
 630     (setq frames (cdr frames))))
 631 (or (assq 'menu-bar-lines default-frame-alist)
 632     (setq default-frame-alist
 633           (cons '(menu-bar-lines . 1) default-frame-alist)))
 634
 635 (set-menubar default-menubar)
 636 \f
 637 (provide 'menubar)
 638
 639 ;;; lmenu.el ends here