/[emacs]/emacs/lisp/buff-menu.el
ViewVC logotype

Diff of /emacs/lisp/buff-menu.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.54 by rms, Thu Nov 1 19:32:39 2001 UTC revision 1.55 by lektu, Mon Dec 16 08:12:59 2002 UTC
# Line 1  Line 1 
1  ;;; buff-menu.el --- buffer menu main function and support functions  ;;; buff-menu.el --- buffer menu main function and support functions
2    
3  ;; Copyright (C) 1985, 86, 87, 93, 94, 95, 2000, 2001  ;; Copyright (C) 1985, 86, 87, 93, 94, 95, 2000, 2001, 2002
4  ;;   Free Software Foundation, Inc.  ;;   Free Software Foundation, Inc.
5    
6  ;; Maintainer: FSF  ;; Maintainer: FSF
# Line 64  Line 64 
64  ; Put buffer *Buffer List* into proper mode right away  ; Put buffer *Buffer List* into proper mode right away
65  ; so that from now on even list-buffers is enough to get a buffer menu.  ; so that from now on even list-buffers is enough to get a buffer menu.
66    
67  (defvar Buffer-menu-buffer-column nil)  (defgroup Buffer-menu nil
68      "Show a menu of all buffers in a buffer."
69      :group 'tools
70      :group 'convenience)
71    
72    (defcustom Buffer-menu-use-header-line t
73      "*Non-nil means to use an immovable header-line."
74      :type 'boolean
75      :group 'Buffer-menu)
76    
77    (defface Buffer-menu-buffer-face
78      '((t (:weight bold)))
79      "Face used to highlight buffer name."
80      :group 'font-lock-highlighting-faces)
81    
82    (defcustom Buffer-menu-buffer+size-width 21
83      "*How wide to jointly make the buffer name and size columns."
84      :type 'number
85      :group 'Buffer-menu)
86    
87    (defcustom Buffer-menu-mode-width 11
88      "*How wide to make the mode name column."
89      :type 'number
90      :group 'Buffer-menu)
91    
92    ; This should get updated & resorted when you click on a column heading
93    (defvar Buffer-menu-sort-column nil
94      "*2 for sorting by buffer names.  5 for sorting by file names.
95    nil for default sorting by visited order.")
96    
97    (defconst Buffer-menu-buffer-column 4)
98    
99  (defvar Buffer-menu-mode-map nil "")  (defvar Buffer-menu-mode-map nil "")
100    
# Line 183  The first column shows `>' for a buffer Line 213  The first column shows `>' for a buffer
213  marked to be displayed, `D' for one you have marked for  marked to be displayed, `D' for one you have marked for
214  deletion, and `.' for the current buffer.  deletion, and `.' for the current buffer.
215    
216    The C column has a `.' for the buffer from which you came.
217    The R column has a `%' if the buffer is read-only.
218  The M column has a `*' if it is modified,  The M column has a `*' if it is modified,
219  or `S' if you have marked it for saving.  or `S' if you have marked it for saving.
 The R column has a `%' if the buffer is read-only.  
220  After this come the buffer name, its size in characters,  After this come the buffer name, its size in characters,
221  its major mode, and the visited file name (if any)."  its major mode, and the visited file name (if any)."
222    (interactive "P")    (interactive "P")
# Line 207  For more information, see the function ` Line 238  For more information, see the function `
238    (message    (message
239     "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help."))     "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help."))
240    
241    (defun Buffer-menu-no-header ()
242      (beginning-of-line)
243      (if (or Buffer-menu-use-header-line
244              (not (eq (char-after) ?C)))
245          t
246        (ding)
247        (forward-line 1)
248        nil))
249    
250  (defun Buffer-menu-mark ()  (defun Buffer-menu-mark ()
251    "Mark buffer on this line for being displayed by \\<Buffer-menu-mode-map>\\[Buffer-menu-select] command."    "Mark buffer on this line for being displayed by \\<Buffer-menu-mode-map>\\[Buffer-menu-select] command."
252    (interactive)    (interactive)
253    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")  
       (ding)  
254      (let ((buffer-read-only nil))      (let ((buffer-read-only nil))
255        (delete-char 1)        (delete-char 1)
256        (insert ?>)        (insert ?>)
# Line 222  For more information, see the function ` Line 260  For more information, see the function `
260    "Cancel all requested operations on buffer on this line and move down.    "Cancel all requested operations on buffer on this line and move down.
261  Optional ARG means move up."  Optional ARG means move up."
262    (interactive "P")    (interactive "P")
263    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")  
       (ding)  
264      (let* ((buf (Buffer-menu-buffer t))      (let* ((buf (Buffer-menu-buffer t))
265             (mod (buffer-modified-p buf))             (mod (buffer-modified-p buf))
266             (readonly (save-excursion (set-buffer buf) buffer-read-only))             (readonly (save-excursion (set-buffer buf) buffer-read-only))
267             (buffer-read-only nil))             (buffer-read-only nil))
268        (delete-char 3)        (delete-char 3)
269        (insert (if readonly (if mod " *%" "  %") (if mod " * " "   ")))))        (insert (if readonly (if mod " %*" " % ") (if mod "  *" "   ")))))
270    (forward-line (if backup -1 1)))    (forward-line (if backup -1 1)))
271    
272  (defun Buffer-menu-backup-unmark ()  (defun Buffer-menu-backup-unmark ()
# Line 245  Optional ARG means move up." Line 281  Optional ARG means move up."
281  Prefix arg is how many buffers to delete.  Prefix arg is how many buffers to delete.
282  Negative arg means delete backwards."  Negative arg means delete backwards."
283    (interactive "p")    (interactive "p")
284    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")              ;header lines  
       (ding)  
285      (let ((buffer-read-only nil))      (let ((buffer-read-only nil))
286        (if (or (null arg) (= arg 0))        (if (or (null arg) (= arg 0))
287            (setq arg 1))            (setq arg 1))
# Line 256  Negative arg means delete backwards." Line 290  Negative arg means delete backwards."
290          (insert ?D)          (insert ?D)
291          (forward-line 1)          (forward-line 1)
292          (setq arg (1- arg)))          (setq arg (1- arg)))
293        (while (< arg 0)        (while (and (< arg 0)
294                      (Buffer-menu-no-header))
295          (delete-char 1)          (delete-char 1)
296          (insert ?D)          (insert ?D)
297          (forward-line -1)          (forward-line -1)
# Line 266  Negative arg means delete backwards." Line 301  Negative arg means delete backwards."
301    "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command    "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command
302  and then move up one line.  Prefix arg means move that many lines."  and then move up one line.  Prefix arg means move that many lines."
303    (interactive "p")    (interactive "p")
304    (Buffer-menu-delete (- (or arg 1)))    (Buffer-menu-delete (- (or arg 1))))
   (while (looking-at " [-M]")  
     (forward-line 1)))  
305    
306  (defun Buffer-menu-save ()  (defun Buffer-menu-save ()
307    "Mark buffer on this line to be saved by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command."    "Mark buffer on this line to be saved by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command."
308    (interactive)    (interactive)
309    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")              ;header lines  
       (ding)  
310      (let ((buffer-read-only nil))      (let ((buffer-read-only nil))
311        (forward-char 1)        (forward-char 2)
312        (delete-char 1)        (delete-char 1)
313        (insert ?S)        (insert ?S)
314        (forward-line 1))))        (forward-line 1))))
# Line 290  and then move up one line.  Prefix arg m Line 321  and then move up one line.  Prefix arg m
321      (set-buffer-modified-p arg))      (set-buffer-modified-p arg))
322    (save-excursion    (save-excursion
323     (beginning-of-line)     (beginning-of-line)
324     (forward-char 1)     (forward-char 2)
325     (if (= (char-after (point)) (if arg ?  ?*))     (if (= (char-after) (if arg ?  ?*))
326         (let ((buffer-read-only nil))         (let ((buffer-read-only nil))
327           (delete-char 1)           (delete-char 1)
328           (insert (if arg ?* ? ))))))           (insert (if arg ?* ? ))))))
# Line 302  and then move up one line.  Prefix arg m Line 333  and then move up one line.  Prefix arg m
333    (save-excursion    (save-excursion
334      (goto-char (point-min))      (goto-char (point-min))
335      (forward-line 1)      (forward-line 1)
336      (while (re-search-forward "^.S" nil t)      (while (re-search-forward "^..S" nil t)
337        (let ((modp nil))        (let ((modp nil))
338          (save-excursion          (save-excursion
339            (set-buffer (Buffer-menu-buffer t))            (set-buffer (Buffer-menu-buffer t))
# Line 437  The current window remains selected." Line 468  The current window remains selected."
468        (setq char (if buffer-read-only ?% ? )))        (setq char (if buffer-read-only ?% ? )))
469      (save-excursion      (save-excursion
470        (beginning-of-line)        (beginning-of-line)
471        (forward-char 2)        (forward-char 1)
472        (if (/= (following-char) char)        (if (/= (following-char) char)
473            (let (buffer-read-only)            (let (buffer-read-only)
474              (delete-char 1)              (delete-char 1)
# Line 446  The current window remains selected." Line 477  The current window remains selected."
477  (defun Buffer-menu-bury ()  (defun Buffer-menu-bury ()
478    "Bury the buffer listed on this line."    "Bury the buffer listed on this line."
479    (interactive)    (interactive)
480    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")              ;header lines  
       (ding)  
481      (save-excursion      (save-excursion
482        (beginning-of-line)        (beginning-of-line)
483        (bury-buffer (Buffer-menu-buffer t))        (bury-buffer (Buffer-menu-buffer t))
# Line 484  For more information, see the function ` Line 513  For more information, see the function `
513    (interactive "P")    (interactive "P")
514    (display-buffer (list-buffers-noselect files-only)))    (display-buffer (list-buffers-noselect files-only)))
515    
516    (defun Buffer-menu-buffer+size (name size &optional name-props size-props)
517      (if (> (+ (length name) (length size) 2) Buffer-menu-buffer+size-width)
518          (setq name
519                (if (string-match "<[0-9]+>$" name)
520                    (concat (substring name 0
521                                       (- Buffer-menu-buffer+size-width
522                                          (max (length size) 3)
523                                          (match-end 0)
524                                          (- (match-beginning 0))
525                                          2))
526                            ":"             ; narrow ellipsis
527                            (match-string 0 name))
528                  (concat (substring name 0
529                                     (- Buffer-menu-buffer+size-width
530                                        (max (length size) 3)
531                                        2))
532                          ":"))))           ; narrow ellipsis
533      (add-text-properties 0 (length name) name-props name)
534      (add-text-properties 0 (length size) size-props size)
535      (concat name
536              (make-string (- Buffer-menu-buffer+size-width
537                              (length name)
538                              (length size))
539                           ? )
540              size))
541    
542  (defun list-buffers-noselect (&optional files-only)  (defun list-buffers-noselect (&optional files-only)
543    "Create and return a buffer with a list of names of existing buffers.    "Create and return a buffer with a list of names of existing buffers.
544  The buffer is named `*Buffer List*'.  The buffer is named `*Buffer List*'.
# Line 491  Note that buffers with names starting wi Line 546  Note that buffers with names starting wi
546  Non-null optional arg FILES-ONLY means mention only file buffers.  Non-null optional arg FILES-ONLY means mention only file buffers.
547    
548  For more information, see the function `buffer-menu'."  For more information, see the function `buffer-menu'."
549    (let ((old-buffer (current-buffer))    (let* ((old-buffer (current-buffer))
550          (standard-output standard-output)           (standard-output standard-output)
551          desired-point)           (mode-end (make-string (- Buffer-menu-mode-width 2) ? ))
552             (header (concat "CRM " (Buffer-menu-buffer+size "Buffer" "Size")
553                             "  Mode" mode-end "File\n"))
554             list desired-point name file mode)
555      (save-excursion      (save-excursion
556        (set-buffer (get-buffer-create "*Buffer List*"))        (set-buffer (get-buffer-create "*Buffer List*"))
557        (setq buffer-read-only nil)        (setq buffer-read-only nil)
558        (erase-buffer)        (erase-buffer)
559        (setq standard-output (current-buffer))        (setq standard-output (current-buffer))
560        (princ "\        (unless Buffer-menu-use-header-line
561   MR Buffer           Size  Mode         File          (insert header "--- ------")
562   -- ------           ----  ----         ----          (indent-to Buffer-menu-buffer+size-width)
563  ")          (insert "----  ----" mode-end "----\n")
564        ;; Record the column where buffer names start.          (put-text-property 1 (point) 'intangible t))
565        (setq Buffer-menu-buffer-column 4)        (setq list
566        (dolist (buffer (buffer-list))              (delq t
567          (let ((name (buffer-name buffer))                    (mapcar
568                (file (buffer-file-name buffer))                     (lambda (buffer)
569                this-buffer-line-start                       (with-current-buffer buffer
570                this-buffer-read-only                         (setq name (buffer-name)
571                (this-buffer-size (buffer-size buffer))                               file (buffer-file-name))
572                this-buffer-mode-name                         (cond
573                this-buffer-directory)                          ;; Don't mention internal buffers.
574            (with-current-buffer buffer                          ((and (string= (substring name 0 1) " ") (null file)))
575              (setq this-buffer-read-only buffer-read-only                          ;; Maybe don't mention buffers without files.
576                    this-buffer-mode-name mode-name)                          ((and files-only (not file)))
577              (unless file                          ((string= name "*Buffer List*"))
578                ;; No visited file.  Check local value of                          ;; Otherwise output info.
579                ;; list-buffers-directory.                          (t
580                (when (and (boundp 'list-buffers-directory)                           (unless file
581                           list-buffers-directory)                             ;; No visited file.  Check local value of
582                  (setq this-buffer-directory list-buffers-directory))))                             ;; list-buffers-directory.
583            (cond                             (when (and (boundp 'list-buffers-directory)
584              ;; Don't mention internal buffers.                                        list-buffers-directory)
585              ((and (string= (substring name 0 1) " ") (null file)))                               (setq file list-buffers-directory)))
586              ;; Maybe don't mention buffers without files.                           (list buffer
587              ((and files-only (not file)))                                 (format "%c%c%c "
588              ((string= name "*Buffer List*"))                                         (if (eq buffer old-buffer) ?. ? )
589              ;; Otherwise output info.                                         ;; Handle readonly status.  The output buffer is special
590              (t                                         ;; cased to appear readonly; it is actually made so at a
591               (setq this-buffer-line-start (point))                                         ;; later date.
592               ;; Identify current buffer.                                         (if (or (eq buffer standard-output)
593               (if (eq buffer old-buffer)                                                 buffer-read-only)
594                   (progn                                             ?% ? )
595                     (setq desired-point (point))                                         ;; Identify modified buffers.
596                     (princ "."))                                         (if (buffer-modified-p) ?* ? ))
597                 (princ " "))                                 name (buffer-size) mode-name file)))))
598               ;; Identify modified buffers.                     (buffer-list))))
599               (princ (if (buffer-modified-p buffer) "*" " "))        (dolist (buffer
600               ;; Handle readonly status.  The output buffer is special                 (if Buffer-menu-sort-column
601               ;; cased to appear readonly; it is actually made so at a                     (sort list
602               ;; later date.                           (if (eq Buffer-menu-sort-column 3)
603               (princ (if (or (eq buffer standard-output)                               (lambda (a b)
604                              this-buffer-read-only)                                 (< (nth Buffer-menu-sort-column a)
605                          "% "                                    (nth Buffer-menu-sort-column b)))
606                        "  "))                             (lambda (a b)
607               (princ name)                               (string< (nth Buffer-menu-sort-column a)
608               ;; Put the buffer name into a text property                                        (nth Buffer-menu-sort-column b)))))
609               ;; so we don't have to extract it from the text.                   list))
610               ;; This way we avoid problems with unusual buffer names.          (if (eq (car buffer) old-buffer)
611               (setq this-buffer-line-start              (setq desired-point (point)))
612                     (+ this-buffer-line-start Buffer-menu-buffer-column))          (insert (cadr buffer)
613               (let ((name-end (point)))                  ;; Put the buffer name into a text property
614                 (indent-to 17 2)                  ;; so we don't have to extract it from the text.
615                 (put-text-property this-buffer-line-start name-end                  ;; This way we avoid problems with unusual buffer names.
616                                    'buffer-name name)                  (Buffer-menu-buffer+size (nth 2 buffer)
617                 (put-text-property this-buffer-line-start (point)                                           (int-to-string (nth 3 buffer))
618                                    'buffer buffer)                                           `(buffer-name ,(nth 2 buffer)
619                 (put-text-property this-buffer-line-start name-end                                             buffer ,(car buffer)
620                                    'mouse-face 'highlight)                                             face Buffer-menu-buffer-face
621                 (put-text-property this-buffer-line-start name-end                                             mouse-face highlight
622                                    'help-echo "mouse-2: select this buffer"))                                             help-echo "mouse-2: select this buffer"))
623               (let ((size (format "%8d" this-buffer-size))                  "  "
624                     (mode this-buffer-mode-name)                  (if (> (length (nth 4 buffer)) Buffer-menu-mode-width)
625                     (excess (- (current-column) 17)))                      (substring (nth 4 buffer) 0 Buffer-menu-mode-width)
626                 (while (and (> excess 0) (= (aref size 0) ?\ ))                    (nth 4 buffer)))
627                   (setq size (substring size 1)          (when (nth 5 buffer)
628                         excess (1- excess)))            (indent-to (+ Buffer-menu-buffer-column Buffer-menu-buffer+size-width
629                 (princ size)                          Buffer-menu-mode-width 4) 1)
630                 (indent-to 27 1)            (princ (abbreviate-file-name (nth 5 buffer))))
631                 (princ mode))          (princ "\n"))
              (indent-to 40 1)  
              (or file (setq file this-buffer-directory))  
              (when file  
                (princ (abbreviate-file-name file)))  
              (princ "\n")))))  
632        (Buffer-menu-mode)        (Buffer-menu-mode)
633          (when Buffer-menu-use-header-line
634            (set (make-local-variable 'Buffer-menu-header-line)
635                 (concat " " header))
636            (setq header-line-format 'Buffer-menu-header-line))
637        ;; DESIRED-POINT doesn't have to be set; it is not when the        ;; DESIRED-POINT doesn't have to be set; it is not when the
638        ;; current buffer is not displayed for some reason.        ;; current buffer is not displayed for some reason.
639        (and desired-point        (and desired-point

Legend:
Removed from v.1.54  
changed lines
  Added in v.1.55

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26