/[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.54.4.1 by miles, Fri Apr 4 06:20:00 2003 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, 2003
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 26
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 16
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  (defvar Buffer-menu-mode-map nil "")  (defconst Buffer-menu-buffer-column 4)
98    
99    (defvar Buffer-menu-mode-map nil
100      "Local keymap for `Buffer-menu-mode' buffers.")
101    
102  (if Buffer-menu-mode-map  (if Buffer-menu-mode-map
103      ()      ()
# Line 169  Letters do not insert themselves; instea Line 200  Letters do not insert themselves; instea
200                  (error "No buffer named `%s'" name)                  (error "No buffer named `%s'" name)
201                nil))                nil))
202        (or (and buf (buffer-name buf) buf)        (or (and buf (buffer-name buf) buf)
203        (if error-if-non-existent-p            (if error-if-non-existent-p
204            (error "No buffer on this line")                (error "No buffer on this line")
205              nil)))))              nil)))))
206    
207  (defun buffer-menu (&optional arg)  (defun buffer-menu (&optional arg)
# Line 183  The first column shows `>' for a buffer Line 214  The first column shows `>' for a buffer
214  marked to be displayed, `D' for one you have marked for  marked to be displayed, `D' for one you have marked for
215  deletion, and `.' for the current buffer.  deletion, and `.' for the current buffer.
216    
217    The C column has a `.' for the buffer from which you came.
218    The R column has a `%' if the buffer is read-only.
219  The M column has a `*' if it is modified,  The M column has a `*' if it is modified,
220  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.  
221  After this come the buffer name, its size in characters,  After this come the buffer name, its size in characters,
222  its major mode, and the visited file name (if any)."  its major mode, and the visited file name (if any)."
223    (interactive "P")    (interactive "P")
# Line 207  For more information, see the function ` Line 239  For more information, see the function `
239    (message    (message
240     "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."))
241    
242    (defun Buffer-menu-no-header ()
243      (beginning-of-line)
244      (if (or Buffer-menu-use-header-line
245              (not (eq (char-after) ?C)))
246          t
247        (ding)
248        (forward-line 1)
249        nil))
250    
251  (defun Buffer-menu-mark ()  (defun Buffer-menu-mark ()
252    "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."
253    (interactive)    (interactive)
254    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")  
       (ding)  
255      (let ((buffer-read-only nil))      (let ((buffer-read-only nil))
256        (delete-char 1)        (delete-char 1)
257        (insert ?>)        (insert ?>)
# Line 222  For more information, see the function ` Line 261  For more information, see the function `
261    "Cancel all requested operations on buffer on this line and move down.    "Cancel all requested operations on buffer on this line and move down.
262  Optional ARG means move up."  Optional ARG means move up."
263    (interactive "P")    (interactive "P")
264    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")  
       (ding)  
265      (let* ((buf (Buffer-menu-buffer t))      (let* ((buf (Buffer-menu-buffer t))
266             (mod (buffer-modified-p buf))             (mod (buffer-modified-p buf))
267             (readonly (save-excursion (set-buffer buf) buffer-read-only))             (readonly (save-excursion (set-buffer buf) buffer-read-only))
268             (buffer-read-only nil))             (buffer-read-only nil))
269        (delete-char 3)        (delete-char 3)
270        (insert (if readonly (if mod " *%" "  %") (if mod " * " "   ")))))        (insert (if readonly (if mod " %*" " % ") (if mod "  *" "   ")))))
271    (forward-line (if backup -1 1)))    (forward-line (if backup -1 1)))
272    
273  (defun Buffer-menu-backup-unmark ()  (defun Buffer-menu-backup-unmark ()
# Line 245  Optional ARG means move up." Line 282  Optional ARG means move up."
282  Prefix arg is how many buffers to delete.  Prefix arg is how many buffers to delete.
283  Negative arg means delete backwards."  Negative arg means delete backwards."
284    (interactive "p")    (interactive "p")
285    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")              ;header lines  
       (ding)  
286      (let ((buffer-read-only nil))      (let ((buffer-read-only nil))
287        (if (or (null arg) (= arg 0))        (if (or (null arg) (= arg 0))
288            (setq arg 1))            (setq arg 1))
# Line 256  Negative arg means delete backwards." Line 291  Negative arg means delete backwards."
291          (insert ?D)          (insert ?D)
292          (forward-line 1)          (forward-line 1)
293          (setq arg (1- arg)))          (setq arg (1- arg)))
294        (while (< arg 0)        (while (and (< arg 0)
295                      (Buffer-menu-no-header))
296          (delete-char 1)          (delete-char 1)
297          (insert ?D)          (insert ?D)
298          (forward-line -1)          (forward-line -1)
# Line 266  Negative arg means delete backwards." Line 302  Negative arg means delete backwards."
302    "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
303  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."
304    (interactive "p")    (interactive "p")
305    (Buffer-menu-delete (- (or arg 1)))    (Buffer-menu-delete (- (or arg 1))))
   (while (looking-at " [-M]")  
     (forward-line 1)))  
306    
307  (defun Buffer-menu-save ()  (defun Buffer-menu-save ()
308    "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."
309    (interactive)    (interactive)
310    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")              ;header lines  
       (ding)  
311      (let ((buffer-read-only nil))      (let ((buffer-read-only nil))
312        (forward-char 1)        (forward-char 2)
313        (delete-char 1)        (delete-char 1)
314        (insert ?S)        (insert ?S)
315        (forward-line 1))))        (forward-line 1))))
# Line 290  and then move up one line.  Prefix arg m Line 322  and then move up one line.  Prefix arg m
322      (set-buffer-modified-p arg))      (set-buffer-modified-p arg))
323    (save-excursion    (save-excursion
324     (beginning-of-line)     (beginning-of-line)
325     (forward-char 1)     (forward-char 2)
326     (if (= (char-after (point)) (if arg ?  ?*))     (if (= (char-after) (if arg ?  ?*))
327         (let ((buffer-read-only nil))         (let ((buffer-read-only nil))
328           (delete-char 1)           (delete-char 1)
329           (insert (if arg ?* ? ))))))           (insert (if arg ?* ? ))))))
# Line 301  and then move up one line.  Prefix arg m Line 333  and then move up one line.  Prefix arg m
333    (interactive)    (interactive)
334    (save-excursion    (save-excursion
335      (goto-char (point-min))      (goto-char (point-min))
336      (forward-line 1)      (unless Buffer-menu-use-header-line
337      (while (re-search-forward "^.S" nil t)        (forward-line 1))
338        (while (re-search-forward "^..S" nil t)
339        (let ((modp nil))        (let ((modp nil))
340          (save-excursion          (save-excursion
341            (set-buffer (Buffer-menu-buffer t))            (set-buffer (Buffer-menu-buffer t))
# Line 313  and then move up one line.  Prefix arg m Line 346  and then move up one line.  Prefix arg m
346            (insert (if modp ?* ? ))))))            (insert (if modp ?* ? ))))))
347    (save-excursion    (save-excursion
348      (goto-char (point-min))      (goto-char (point-min))
349      (forward-line 1)      (unless Buffer-menu-use-header-line
350          (forward-line 1))
351      (let ((buff-menu-buffer (current-buffer))      (let ((buff-menu-buffer (current-buffer))
352            (buffer-read-only nil))            (buffer-read-only nil))
353        (while (search-forward "\nD" nil t)        (while (re-search-forward "^D" nil t)
354          (forward-char -1)          (forward-char -1)
355          (let ((buf (Buffer-menu-buffer nil)))          (let ((buf (Buffer-menu-buffer nil)))
356            (or (eq buf nil)            (or (eq buf nil)
# Line 326  and then move up one line.  Prefix arg m Line 360  and then move up one line.  Prefix arg m
360              (progn (delete-char 1)              (progn (delete-char 1)
361                     (insert ? ))                     (insert ? ))
362            (delete-region (point) (progn (forward-line 1) (point)))            (delete-region (point) (progn (forward-line 1) (point)))
363              (forward-char -1)))))))              (unless (bobp)
364                  (forward-char -1))))))))
365    
366  (defun Buffer-menu-select ()  (defun Buffer-menu-select ()
367    "Select this line's buffer; also display buffers marked with `>'.    "Select this line's buffer; also display buffers marked with `>'.
# Line 339  in the selected frame." Line 374  in the selected frame."
374          (others ())          (others ())
375          tem)          tem)
376      (goto-char (point-min))      (goto-char (point-min))
377      (while (search-forward "\n>" nil t)      (unless Buffer-menu-use-header-line
378          (forward-line 1))
379        (while (re-search-forward "^>" nil t)
380        (setq tem (Buffer-menu-buffer t))        (setq tem (Buffer-menu-buffer t))
381        (let ((buffer-read-only nil))        (let ((buffer-read-only nil))
382          (delete-char -1)          (delete-char -1)
# Line 437  The current window remains selected." Line 474  The current window remains selected."
474        (setq char (if buffer-read-only ?% ? )))        (setq char (if buffer-read-only ?% ? )))
475      (save-excursion      (save-excursion
476        (beginning-of-line)        (beginning-of-line)
477        (forward-char 2)        (forward-char 1)
478        (if (/= (following-char) char)        (if (/= (following-char) char)
479            (let (buffer-read-only)            (let (buffer-read-only)
480              (delete-char 1)              (delete-char 1)
# Line 446  The current window remains selected." Line 483  The current window remains selected."
483  (defun Buffer-menu-bury ()  (defun Buffer-menu-bury ()
484    "Bury the buffer listed on this line."    "Bury the buffer listed on this line."
485    (interactive)    (interactive)
486    (beginning-of-line)    (when (Buffer-menu-no-header)
   (if (looking-at " [-M]")              ;header lines  
       (ding)  
487      (save-excursion      (save-excursion
488        (beginning-of-line)        (beginning-of-line)
489        (bury-buffer (Buffer-menu-buffer t))        (bury-buffer (Buffer-menu-buffer t))
# Line 484  For more information, see the function ` Line 519  For more information, see the function `
519    (interactive "P")    (interactive "P")
520    (display-buffer (list-buffers-noselect files-only)))    (display-buffer (list-buffers-noselect files-only)))
521    
522    (defun Buffer-menu-buffer+size (name size &optional name-props size-props)
523      (if (> (+ (length name) (length size) 2) Buffer-menu-buffer+size-width)
524          (setq name
525                (if (string-match "<[0-9]+>$" name)
526                    (concat (substring name 0
527                                       (- Buffer-menu-buffer+size-width
528                                          (max (length size) 3)
529                                          (match-end 0)
530                                          (- (match-beginning 0))
531                                          2))
532                            ":"             ; narrow ellipsis
533                            (match-string 0 name))
534                  (concat (substring name 0
535                                     (- Buffer-menu-buffer+size-width
536                                        (max (length size) 3)
537                                        2))
538                          ":")))            ; narrow ellipsis
539        ;; Don't put properties on (buffer-name).
540        (setq name (copy-sequence name)))
541      (add-text-properties 0 (length name) name-props name)
542      (add-text-properties 0 (length size) size-props size)
543      (concat name
544              (make-string (- Buffer-menu-buffer+size-width
545                              (length name)
546                              (length size))
547                           ? )
548              size))
549    
550  (defun list-buffers-noselect (&optional files-only)  (defun list-buffers-noselect (&optional files-only)
551    "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.
552  The buffer is named `*Buffer List*'.  The buffer is named `*Buffer List*'.
# Line 491  Note that buffers with names starting wi Line 554  Note that buffers with names starting wi
554  Non-null optional arg FILES-ONLY means mention only file buffers.  Non-null optional arg FILES-ONLY means mention only file buffers.
555    
556  For more information, see the function `buffer-menu'."  For more information, see the function `buffer-menu'."
557    (let ((old-buffer (current-buffer))    (let* ((old-buffer (current-buffer))
558          (standard-output standard-output)           (standard-output standard-output)
559          desired-point)           (mode-end (make-string (- Buffer-menu-mode-width 2) ? ))
560             (header (concat (propertize "CRM " 'face 'fixed-pitch)
561                             (Buffer-menu-buffer+size "Buffer" "Size")
562                             "  Mode" mode-end "File\n"))
563             list desired-point name file mode)
564        (when Buffer-menu-use-header-line
565          (let ((spaces
566                 ;; FIXME: This is using the settings of the current frame rather
567                 ;; than the frame into which the buffer will be displayed.
568                 (/ (+ 0.0 (or (frame-parameter nil 'left-fringe) 0)
569                       (or (if (eq (frame-parameter nil 'vertical-scroll-bars)
570                                   'left)
571                               (frame-parameter nil 'scroll-bar-width))
572                           0))
573                    (frame-char-width)))
574                (pos 0))
575            ;; Turn spaces in the header into stretch specs so they work
576            ;; regardless of the header-line face.
577            (while (string-match "[ \t]+" header pos)
578              (setq pos (match-end 0))
579              (put-text-property (match-beginning 0) pos 'display
580                                 ;; Assume fixed-size chars
581                                 (list 'space :align-to (+ spaces pos))
582                                 header))
583            ;; Add the leading space
584            (setq header (concat (propertize (make-string (floor spaces) ? )
585                                             'display (list 'space :width spaces))
586                                 header))))
587      (save-excursion      (save-excursion
588        (set-buffer (get-buffer-create "*Buffer List*"))        (set-buffer (get-buffer-create "*Buffer List*"))
589        (setq buffer-read-only nil)        (setq buffer-read-only nil)
590        (erase-buffer)        (erase-buffer)
591        (setq standard-output (current-buffer))        (setq standard-output (current-buffer))
592        (princ "\        (unless Buffer-menu-use-header-line
593   MR Buffer           Size  Mode         File          (insert header "--- ------")
594   -- ------           ----  ----         ----          (indent-to Buffer-menu-buffer+size-width)
595  ")          (insert "----  ----" mode-end "----\n")
596        ;; Record the column where buffer names start.          (put-text-property 1 (point) 'intangible t))
597        (setq Buffer-menu-buffer-column 4)        (setq list
598        (dolist (buffer (buffer-list))              (delq t
599          (let ((name (buffer-name buffer))                    (mapcar
600                (file (buffer-file-name buffer))                     (lambda (buffer)
601                this-buffer-line-start                       (with-current-buffer buffer
602                this-buffer-read-only                         (setq name (buffer-name)
603                (this-buffer-size (buffer-size buffer))                               file (buffer-file-name))
604                this-buffer-mode-name                         (cond
605                this-buffer-directory)                          ;; Don't mention internal buffers.
606            (with-current-buffer buffer                          ((and (string= (substring name 0 1) " ") (null file)))
607              (setq this-buffer-read-only buffer-read-only                          ;; Maybe don't mention buffers without files.
608                    this-buffer-mode-name mode-name)                          ((and files-only (not file)))
609              (unless file                          ((string= name "*Buffer List*"))
610                ;; No visited file.  Check local value of                          ;; Otherwise output info.
611                ;; list-buffers-directory.                          (t
612                (when (and (boundp 'list-buffers-directory)                           (unless file
613                           list-buffers-directory)                             ;; No visited file.  Check local value of
614                  (setq this-buffer-directory list-buffers-directory))))                             ;; list-buffers-directory.
615            (cond                             (when (and (boundp 'list-buffers-directory)
616              ;; Don't mention internal buffers.                                        list-buffers-directory)
617              ((and (string= (substring name 0 1) " ") (null file)))                               (setq file list-buffers-directory)))
618              ;; Maybe don't mention buffers without files.                           (list buffer
619              ((and files-only (not file)))                                 (format "%c%c%c "
620              ((string= name "*Buffer List*"))                                         (if (eq buffer old-buffer) ?. ? )
621              ;; Otherwise output info.                                         ;; Handle readonly status.  The output buffer is special
622              (t                                         ;; cased to appear readonly; it is actually made so at a
623               (setq this-buffer-line-start (point))                                         ;; later date.
624               ;; Identify current buffer.                                         (if (or (eq buffer standard-output)
625               (if (eq buffer old-buffer)                                                 buffer-read-only)
626                   (progn                                             ?% ? )
627                     (setq desired-point (point))                                         ;; Identify modified buffers.
628                     (princ "."))                                         (if (buffer-modified-p) ?* ? ))
629                 (princ " "))                                 name (buffer-size) mode-name file)))))
630               ;; Identify modified buffers.                     (buffer-list))))
631               (princ (if (buffer-modified-p buffer) "*" " "))        (dolist (buffer
632               ;; Handle readonly status.  The output buffer is special                 (if Buffer-menu-sort-column
633               ;; cased to appear readonly; it is actually made so at a                     (sort list
634               ;; later date.                           (if (eq Buffer-menu-sort-column 3)
635               (princ (if (or (eq buffer standard-output)                               (lambda (a b)
636                              this-buffer-read-only)                                 (< (nth Buffer-menu-sort-column a)
637                          "% "                                    (nth Buffer-menu-sort-column b)))
638                        "  "))                             (lambda (a b)
639               (princ name)                               (string< (nth Buffer-menu-sort-column a)
640               ;; Put the buffer name into a text property                                        (nth Buffer-menu-sort-column b)))))
641               ;; so we don't have to extract it from the text.                   list))
642               ;; This way we avoid problems with unusual buffer names.          (if (eq (car buffer) old-buffer)
643               (setq this-buffer-line-start              (setq desired-point (point)))
644                     (+ this-buffer-line-start Buffer-menu-buffer-column))          (insert (cadr buffer)
645               (let ((name-end (point)))                  ;; Put the buffer name into a text property
646                 (indent-to 17 2)                  ;; so we don't have to extract it from the text.
647                 (put-text-property this-buffer-line-start name-end                  ;; This way we avoid problems with unusual buffer names.
648                                    'buffer-name name)                  (Buffer-menu-buffer+size (nth 2 buffer)
649                 (put-text-property this-buffer-line-start (point)                                           (int-to-string (nth 3 buffer))
650                                    'buffer buffer)                                           `(buffer-name ,(nth 2 buffer)
651                 (put-text-property this-buffer-line-start name-end                                             buffer ,(car buffer)
652                                    'mouse-face 'highlight)                                             face Buffer-menu-buffer-face
653                 (put-text-property this-buffer-line-start name-end                                             mouse-face highlight
654                                    'help-echo "mouse-2: select this buffer"))                                             help-echo "mouse-2: select this buffer"))
655               (let ((size (format "%8d" this-buffer-size))                  "  "
656                     (mode this-buffer-mode-name)                  (if (> (length (nth 4 buffer)) Buffer-menu-mode-width)
657                     (excess (- (current-column) 17)))                      (substring (nth 4 buffer) 0 Buffer-menu-mode-width)
658                 (while (and (> excess 0) (= (aref size 0) ?\ ))                    (nth 4 buffer)))
659                   (setq size (substring size 1)          (when (nth 5 buffer)
660                         excess (1- excess)))            (indent-to (+ Buffer-menu-buffer-column Buffer-menu-buffer+size-width
661                 (princ size)                          Buffer-menu-mode-width 4) 1)
662                 (indent-to 27 1)            (princ (abbreviate-file-name (nth 5 buffer))))
663                 (princ mode))          (princ "\n"))
              (indent-to 40 1)  
              (or file (setq file this-buffer-directory))  
              (when file  
                (princ (abbreviate-file-name file)))  
              (princ "\n")))))  
664        (Buffer-menu-mode)        (Buffer-menu-mode)
665          (when Buffer-menu-use-header-line
666            (setq header-line-format header))
667        ;; 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
668        ;; current buffer is not displayed for some reason.        ;; current buffer is not displayed for some reason.
669        (and desired-point        (and desired-point

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

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