X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d5aacb4655c06850d35697ccdf2ec71d7d7ae632..27422a9d8a01ea0658d689be824936674bb20d6e:/lisp/buff-menu.el diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 02f93a0cff..9418eebe98 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -1,7 +1,7 @@ -;;; buff-menu.el --- buffer menu main function and support functions +;;; buff-menu.el --- buffer menu main function and support functions -*- coding:utf-8 -*- -;; Copyright (C) 1985, 86, 87, 93, 94, 95, 2000, 2001, 2002, 03, 2004 -;; Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 2000, 2001, 2002, 2003, +;; 2004, 2005 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: convenience @@ -20,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -74,9 +74,10 @@ :type 'boolean :group 'Buffer-menu) -(defface Buffer-menu-buffer-face +(defface Buffer-menu-buffer '((t (:weight bold))) "Face used to highlight buffer name." + :group 'Buffer-menu :group 'font-lock-highlighting-faces) (defcustom Buffer-menu-buffer+size-width 26 @@ -99,6 +100,14 @@ nil for default sorting by visited order.") (defvar Buffer-menu-mode-map nil "Local keymap for `Buffer-menu-mode' buffers.") +(defvar Buffer-menu-files-only nil + "Non-nil if the current buffer-menu lists only file buffers. +This variable determines whether reverting the buffer lists only +file buffers. It affects both manual reverting and reverting by +Auto Revert Mode.") + +(make-variable-buffer-local 'Buffer-menu-files-only) + (if Buffer-menu-mode-map () (setq Buffer-menu-mode-map (make-keymap)) @@ -131,7 +140,9 @@ nil for default sorting by visited order.") (define-key Buffer-menu-mode-map "b" 'Buffer-menu-bury) (define-key Buffer-menu-mode-map "g" 'Buffer-menu-revert) (define-key Buffer-menu-mode-map "V" 'Buffer-menu-view) + (define-key Buffer-menu-mode-map "T" 'Buffer-menu-toggle-files-only) (define-key Buffer-menu-mode-map [mouse-2] 'Buffer-menu-mouse-select) + (define-key Buffer-menu-mode-map [follow-link] 'mouse-face) ) ;; Buffer Menu mode is suitable only for specially formatted data. @@ -167,24 +178,57 @@ Letters do not insert themselves; instead, they are commands. \\[Buffer-menu-backup-unmark] -- back up a line and remove marks. \\[Buffer-menu-toggle-read-only] -- toggle read-only status of buffer on this line. \\[Buffer-menu-revert] -- update the list of buffers. +\\[Buffer-menu-toggle-files-only] -- toggle whether the menu displays only file buffers. \\[Buffer-menu-bury] -- bury the buffer listed on this line." (kill-all-local-variables) (use-local-map Buffer-menu-mode-map) (setq major-mode 'Buffer-menu-mode) (setq mode-name "Buffer Menu") - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'Buffer-menu-revert-function) + (set (make-local-variable 'revert-buffer-function) + 'Buffer-menu-revert-function) + (set (make-local-variable 'buffer-stale-function) + #'(lambda (&optional noconfirm) 'fast)) (setq truncate-lines t) (setq buffer-read-only t) - (run-hooks 'buffer-menu-mode-hook)) + (run-mode-hooks 'buffer-menu-mode-hook)) +;; This function exists so we can make the doc string of Buffer-menu-mode +;; look nice. (defun Buffer-menu-revert () "Update the list of buffers." (interactive) (revert-buffer)) (defun Buffer-menu-revert-function (ignore1 ignore2) - (list-buffers)) + (or (eq buffer-undo-list t) + (setq buffer-undo-list nil)) + ;; We can not use save-excursion here. The buffer gets erased. + (let ((opoint (point)) + (eobp (eobp)) + (ocol (current-column)) + (oline (progn (move-to-column 4) + (get-text-property (point) 'buffer))) + (prop (point-min)) + ;; do not make undo records for the reversion. + (buffer-undo-list t)) + (list-buffers-noselect Buffer-menu-files-only) + (if oline + (while (setq prop (next-single-property-change prop 'buffer)) + (when (eq (get-text-property prop 'buffer) oline) + (goto-char prop) + (move-to-column ocol))) + (goto-char (if eobp (point-max) opoint))))) + +(defun Buffer-menu-toggle-files-only (arg) + "Toggle whether the current buffer-menu displays only file buffers. +With a positive ARG display only file buffers. With zero or +negative ARG, display other buffers as well." + (interactive "P") + (setq Buffer-menu-files-only + (cond ((not arg) (not Buffer-menu-files-only)) + ((> (prefix-numeric-value arg) 0) t))) + (revert-buffer)) + (defun Buffer-menu-buffer (error-if-non-existent-p) "Return buffer described by this line of buffer menu." @@ -259,7 +303,7 @@ For more information, see the function `buffer-menu'." (defun Buffer-menu-unmark (&optional backup) "Cancel all requested operations on buffer on this line and move down. -Optional ARG means move up." +Optional prefix arg means move up." (interactive "P") (when (Buffer-menu-no-header) (let* ((buf (Buffer-menu-buffer t)) @@ -323,18 +367,21 @@ and then move up one line. Prefix arg means move that many lines." (save-excursion (beginning-of-line) (forward-char 2) - (if (= (char-after) (if arg ? ?*)) + (if (= (char-after) (if arg ?\s ?*)) (let ((buffer-read-only nil)) (delete-char 1) - (insert (if arg ?* ? )))))) + (insert (if arg ?* ?\s)))))) + +(defun Buffer-menu-beginning () + (goto-char (point-min)) + (unless Buffer-menu-use-header-line + (forward-line))) (defun Buffer-menu-execute () "Save and/or delete buffers marked with \\\\[Buffer-menu-save] or \\\\[Buffer-menu-delete] commands." (interactive) (save-excursion - (goto-char (point-min)) - (unless Buffer-menu-use-header-line - (forward-line 1)) + (Buffer-menu-beginning) (while (re-search-forward "^..S" nil t) (let ((modp nil)) (save-excursion @@ -343,11 +390,9 @@ and then move up one line. Prefix arg means move that many lines." (setq modp (buffer-modified-p))) (let ((buffer-read-only nil)) (delete-char -1) - (insert (if modp ?* ? )))))) + (insert (if modp ?* ?\s)))))) (save-excursion - (goto-char (point-min)) - (unless Buffer-menu-use-header-line - (forward-line 1)) + (Buffer-menu-beginning) (let ((buff-menu-buffer (current-buffer)) (buffer-read-only nil)) (while (re-search-forward "^D" nil t) @@ -358,7 +403,7 @@ and then move up one line. Prefix arg means move that many lines." (save-excursion (kill-buffer buf))) (if (and buf (buffer-name buf)) (progn (delete-char 1) - (insert ? )) + (insert ?\s)) (delete-region (point) (progn (forward-line 1) (point))) (unless (bobp) (forward-char -1)))))))) @@ -373,14 +418,12 @@ in the selected frame." (menu (current-buffer)) (others ()) tem) - (goto-char (point-min)) - (unless Buffer-menu-use-header-line - (forward-line 1)) + (Buffer-menu-beginning) (while (re-search-forward "^>" nil t) (setq tem (Buffer-menu-buffer t)) (let ((buffer-read-only nil)) (delete-char -1) - (insert ?\ )) + (insert ?\s)) (or (eq tem buff) (memq tem others) (setq others (cons tem others)))) (setq others (nreverse others) tem (/ (1- (frame-height)) (1+ (length others)))) @@ -451,14 +494,19 @@ in the selected frame." "Make the other window select this line's buffer. The current window remains selected." (interactive) - (display-buffer (Buffer-menu-buffer t))) + (let ((pop-up-windows t) + same-window-buffer-names + same-window-regexps) + (display-buffer (Buffer-menu-buffer t)))) (defun Buffer-menu-2-window () "Select this line's buffer, with previous buffer in second window." (interactive) (let ((buff (Buffer-menu-buffer t)) (menu (current-buffer)) - (pop-up-windows t)) + (pop-up-windows t) + same-window-buffer-names + same-window-regexps) (delete-other-windows) (switch-to-buffer (other-buffer)) (pop-to-buffer buff) @@ -471,7 +519,7 @@ The current window remains selected." (save-excursion (set-buffer (Buffer-menu-buffer t)) (vc-toggle-read-only) - (setq char (if buffer-read-only ?% ? ))) + (setq char (if buffer-read-only ?% ?\s))) (save-excursion (beginning-of-line) (forward-char 1) @@ -544,7 +592,7 @@ For more information, see the function `buffer-menu'." (make-string (- Buffer-menu-buffer+size-width (length name) (length size)) - ? ) + ?\s) size)) (defun Buffer-menu-sort (column) @@ -555,39 +603,87 @@ For more information, see the function `buffer-menu'." (if (< column 2) (setq column 2)) (if (> column 5) (setq column 5))) (setq Buffer-menu-sort-column column) - (Buffer-menu-revert)) + (let (buffer-read-only l buf m1 m2) + (save-excursion + (Buffer-menu-beginning) + (while (not (eobp)) + (when (buffer-live-p (setq buf (get-text-property (+ (point) 4) 'buffer))) + (setq m1 (char-after) + m1 (if (memq m1 '(?> ?D)) m1) + m2 (char-after (+ (point) 2)) + m2 (if (eq m2 ?S) m2)) + (if (or m1 m2) + (push (list buf m1 m2) l))) + (forward-line))) + (Buffer-menu-revert) + (setq buffer-read-only) + (save-excursion + (Buffer-menu-beginning) + (while (not (eobp)) + (when (setq buf (assq (get-text-property (+ (point) 4) 'buffer) l)) + (setq m1 (cadr buf) + m2 (cadr (cdr buf))) + (when m1 + (delete-char 1) + (insert m1) + (backward-char 1)) + (when m2 + (forward-char 2) + (delete-char 1) + (insert m2))) + (forward-line))))) (defun Buffer-menu-make-sort-button (name column) (if (equal column Buffer-menu-sort-column) (setq column nil)) (propertize name 'help-echo (if column - (concat "mouse-2: sort by " (downcase name)) - "mouse-2: sort by visited order") + (if Buffer-menu-use-header-line + (concat "mouse-2: sort by " (downcase name)) + (concat "mouse-2, RET: sort by " + (downcase name))) + (if Buffer-menu-use-header-line + "mouse-2: sort by visited order" + "mouse-2, RET: sort by visited order")) 'mouse-face 'highlight 'keymap (let ((map (make-sparse-keymap))) - (define-key map [header-line mouse-2] - `(lambda () (interactive) - (Buffer-menu-sort ,column))) + (if Buffer-menu-use-header-line + (define-key map [header-line mouse-2] + `(lambda (e) + (interactive "e") + (save-window-excursion + (if e (mouse-select-window e)) + (Buffer-menu-sort ,column)))) + (define-key map [mouse-2] + `(lambda (e) + (interactive "e") + (if e (mouse-select-window e)) + (Buffer-menu-sort ,column))) + (define-key map "\C-m" + `(lambda () (interactive) + (Buffer-menu-sort ,column)))) map))) -(defun list-buffers-noselect (&optional files-only) +(defun list-buffers-noselect (&optional files-only buffer-list) "Create and return a buffer with a list of names of existing buffers. The buffer is named `*Buffer List*'. Note that buffers with names starting with spaces are omitted. Non-null optional arg FILES-ONLY means mention only file buffers. +If BUFFER-LIST is non-nil, it should be a list of buffers; +it means list those buffers and no others. + For more information, see the function `buffer-menu'." (let* ((old-buffer (current-buffer)) (standard-output standard-output) - (mode-end (make-string (- Buffer-menu-mode-width 2) ? )) - (header (concat " " (propertize "CRM " 'face 'fixed-pitch) + (mode-end (make-string (- Buffer-menu-mode-width 2) ?\s)) + (header (concat "CRM " (Buffer-menu-buffer+size (Buffer-menu-make-sort-button "Buffer" 2) (Buffer-menu-make-sort-button "Size" 3)) " " (Buffer-menu-make-sort-button "Mode" 4) mode-end (Buffer-menu-make-sort-button "File" 5) "\n")) - list desired-point name file) + list desired-point) (when Buffer-menu-use-header-line (let ((pos 0)) ;; Turn spaces in the header into stretch specs so they work @@ -595,52 +691,67 @@ For more information, see the function `buffer-menu'." (while (string-match "[ \t]+" header pos) (setq pos (match-end 0)) (put-text-property (match-beginning 0) pos 'display - ;; Assume fixed-size chars - (list 'space :align-to (1- pos)) - header)))) + ;; Assume fixed-size chars in the buffer. + (list 'space :align-to pos) + header))) + ;; Try to better align the one-char headers. + (put-text-property 0 3 'face 'fixed-pitch header) + ;; Add a "dummy" leading space to align the beginning of the header + ;; line with the beginning of the text (rather than with the left + ;; scrollbar or the left fringe). –-Stef + (setq header (concat (propertize " " 'display '(space :align-to 0)) + header))) (with-current-buffer (get-buffer-create "*Buffer List*") (setq buffer-read-only nil) (erase-buffer) (setq standard-output (current-buffer)) (unless Buffer-menu-use-header-line - (insert header (propertize "---" 'face 'fixed-pitch) " ") - (insert (Buffer-menu-buffer+size "------" "----")) - (insert " ----" mode-end "----\n") - (put-text-property 1 (point) 'intangible t)) - (setq list - (delq t - (mapcar - (lambda (buffer) - (with-current-buffer buffer - (setq name (buffer-name) - file (buffer-file-name)) - (cond - ;; Don't mention internal buffers. - ((and (string= (substring name 0 1) " ") (null file))) - ;; Maybe don't mention buffers without files. - ((and files-only (not file))) - ((string= name "*Buffer List*")) - ;; Otherwise output info. - (t - (unless file - ;; No visited file. Check local value of - ;; list-buffers-directory. - (when (and (boundp 'list-buffers-directory) - list-buffers-directory) - (setq file list-buffers-directory))) - (list buffer - (format "%c%c%c " - (if (eq buffer old-buffer) ?. ? ) - ;; Handle readonly status. The output buffer is special - ;; cased to appear readonly; it is actually made so at a - ;; later date. - (if (or (eq buffer standard-output) - buffer-read-only) - ?% ? ) - ;; Identify modified buffers. - (if (buffer-modified-p) ?* ? )) - name (buffer-size) mode-name file))))) - (buffer-list)))) + (let ((underline (if (char-displayable-p ?—) ?— ?-))) + (insert header + (apply 'string + (mapcar (lambda (c) + (if (memq c '(?\n ?\s)) c underline)) + header))))) + ;; Collect info for every buffer we're interested in. + (dolist (buffer (or buffer-list (buffer-list))) + (with-current-buffer buffer + (let ((name (buffer-name)) + (file buffer-file-name)) + (unless (and (not buffer-list) + (or + ;; Don't mention internal buffers. + (and (string= (substring name 0 1) " ") (null file)) + ;; Maybe don't mention buffers without files. + (and files-only (not file)) + (string= name "*Buffer List*"))) + ;; Otherwise output info. + (let ((mode (concat (format-mode-line mode-name nil nil buffer) + (if mode-line-process + (format-mode-line mode-line-process + nil nil buffer)))) + (bits (string + (if (eq buffer old-buffer) ?. ?\s) + ;; Handle readonly status. The output buffer + ;; is special cased to appear readonly; it is + ;; actually made so at a later date. + (if (or (eq buffer standard-output) + buffer-read-only) + ?% ?\s) + ;; Identify modified buffers. + (if (buffer-modified-p) ?* ?\s) + ;; Space separator. + ?\s))) + (unless file + ;; No visited file. Check local value of + ;; list-buffers-directory. + (when (and (boundp 'list-buffers-directory) + list-buffers-directory) + (setq file list-buffers-directory))) + (push (list buffer bits name (buffer-size) mode file) + list)))))) + ;; Preserve the original buffer-list ordering, just in case. + (setq list (nreverse list)) + ;; Place the buffers's info in the output buffer, sorted if necessary. (dolist (buffer (if Buffer-menu-sort-column (sort list @@ -662,7 +773,7 @@ For more information, see the function `buffer-menu'." (int-to-string (nth 3 buffer)) `(buffer-name ,(nth 2 buffer) buffer ,(car buffer) - face Buffer-menu-buffer-face + font-lock-face Buffer-menu-buffer mouse-face highlight help-echo "mouse-2: select this buffer")) " " @@ -681,7 +792,9 @@ For more information, see the function `buffer-menu'." ;; current buffer is not displayed for some reason. (and desired-point (goto-char desired-point)) + (setq Buffer-menu-files-only files-only) + (set-buffer-modified-p nil) (current-buffer)))) -;;; arch-tag: e7dfcfc9-6cb2-46e4-bf55-8ef1936d83c6 +;; arch-tag: e7dfcfc9-6cb2-46e4-bf55-8ef1936d83c6 ;;; buff-menu.el ends here