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