- "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) ?\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)
- (when Buffer-menu-use-header-line
- (let ((pos 0))
- ;; Turn whitespace chars in the header into stretch specs so
- ;; they work regardless of the header-line face.
- (while (string-match "[ \t\n]+" header pos)
- (setq pos (match-end 0))
- (put-text-property (match-beginning 0) pos 'display
- ;; 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))
- ;; Force L2R direction, to avoid messing the display if the
- ;; first buffer in the list happens to begin with a strong R2L
- ;; character.
- (setq bidi-paragraph-direction 'left-to-right)
- (unless Buffer-menu-use-header-line
- ;; Use U+2014 (EM DASH) to underline if possible, else use ASCII
- ;; (i.e. U+002D, HYPHEN-MINUS).
- (let ((underline (if (char-displayable-p ?\u2014) ?\u2014 ?-)))
- (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
- (when Buffer-menu-use-frame-buffer-list
- (selected-frame)))))
- (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 and, for Info buffers,
- ;; Info-current-file.
- (cond ((and (boundp 'list-buffers-directory)
- list-buffers-directory)
- (setq file list-buffers-directory))
- ((eq major-mode 'Info-mode)
- (setq file Info-current-file)
- (cond
- ((equal file "dir")
- (setq file "*Info Directory*"))
- ((eq file 'apropos)
- (setq file "*Info Apropos*"))
- ((eq file 'history)
- (setq file "*Info History*"))
- ((eq file 'toc)
- (setq file "*Info TOC*"))
- ((not (stringp file)) ;; avoid errors
- (setq file nil))
- (t
- (setq file (concat "("
- (file-name-nondirectory file)
- ") "
- Info-current-node)))))))
- (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
- (if (eq Buffer-menu-sort-column 3)
- (lambda (a b)
- (< (nth Buffer-menu-sort-column a)
- (nth Buffer-menu-sort-column b)))
- (lambda (a b)
- (string< (nth Buffer-menu-sort-column a)
- (nth Buffer-menu-sort-column b)))))
- list))
- (if (eq (car buffer) old-buffer)
- (setq desired-point (point)))
- (insert (cadr buffer)
- ;; Put the buffer name into a text property
- ;; so we don't have to extract it from the text.
- ;; This way we avoid problems with unusual buffer names.
- (let ((name (nth 2 buffer))
- (size (int-to-string (nth 3 buffer))))
- (Buffer-menu-buffer+size name size
- `(buffer-name ,name
- buffer ,(car buffer)
- font-lock-face buffer-menu-buffer
- mouse-face highlight
- help-echo
- ,(if (>= (length name)
- (- Buffer-menu-buffer+size-width
- (max (length size) 3)
- 2))
- name
- "mouse-2: select this buffer"))))
- " "
- (if (> (string-width (nth 4 buffer)) Buffer-menu-mode-width)
- (truncate-string-to-width (nth 4 buffer)
- Buffer-menu-mode-width)
- (nth 4 buffer)))
- (when (nth 5 buffer)
- (indent-to (+ Buffer-menu-buffer-column Buffer-menu-buffer+size-width
- Buffer-menu-mode-width 4) 1)
- (princ (abbreviate-file-name (nth 5 buffer))))
- (princ "\n"))