From xemacs-m  Sun Feb 16 15:56:35 1997
Received: from gwa.ericsson.com (gwa.ericsson.com [198.215.127.2])
	by xemacs.org (8.8.5/8.8.5) with ESMTP id PAA06426
	for <xemacs-beta@xemacs.org>; Sun, 16 Feb 1997 15:56:34 -0600 (CST)
Received: from mr1.exu.ericsson.se (mr1.exu.ericsson.com [138.85.147.11]) by gwa.ericsson.com (8.8.2/8.8.2) with ESMTP id PAA03581 for <xemacs-beta@xemacs.org>; Sun, 16 Feb 1997 15:56:04 -0600 (CST)
Received: from screamer.rtp.ericsson.se (screamer.rtp.ericsson.se [147.117.133.13]) by mr1.exu.ericsson.se (8.7.1/NAHUB-MR1.1) with SMTP id PAA09097 for <xemacs-beta@xemacs.org>; Sun, 16 Feb 1997 15:56:04 -0600 (CST)
Received: from rcur (rcur18.rtp.ericsson.se [147.117.133.138]) by screamer.rtp.ericsson.se (8.6.12/8.6.4) with ESMTP id QAA02219 for <xemacs-beta@xemacs.org>; Sun, 16 Feb 1997 16:56:03 -0500
To: XEmacs Mailing List <xemacs-beta@xemacs.org>
Subject: A different list-buffers function
Mime-Version: 1.0 (generated by tm-edit 7.105)
Content-Type: multipart/mixed;
 boundary="Multipart_Sun_Feb_16_16:56:01_1997-1"
Content-Transfer-Encoding: 7bit
Date: Sun, 16 Feb 1997 16:56:02 -0500
Message-ID: <29189.856130162@rtp.ericsson.se>
From: Raymond Toy <toy@rtp.ericsson.se>

--Multipart_Sun_Feb_16_16:56:01_1997-1
Content-Type: text/plain; charset=US-ASCII


I made these a while back when list-buffers didn't sort the buffers.
I see that 20.0-b1 (and earlier?) does now.  However, I still find it
annoying that when buffer names get too long the columns are no longer
correct.  Here are modified versions that line up the columns if
possible.  If any column is too long, it uses the current behavior:
print it out anyway.

Ray

Hmm, I guess I should look to see if these functions have changed in
20.0-b1....


--Multipart_Sun_Feb_16_16:56:01_1997-1
Content-Type: application/octet-stream; type=emacs-lisp
Content-Disposition: attachment; filename="rlt-list-buffers.el"
Content-Transfer-Encoding: 7bit

;;;; Replacement for buff-menu.  These functions produces a buffer
;;;; window that is sorted in the same order as the buffers menu.
;;;; Also, it automatically arranges for the width of the columns to
;;;; be the right size so everything stays lined up.  Cool.

(defun list-buffers (&optional files-only)
  "Display a list of names of existing buffers.
The list is displayed in a buffer named `*Buffer List*'.
Note that buffers with names starting with spaces are omitted.
Non-null optional arg FILES-ONLY means mention only file buffers.

The M column contains a * for buffers that are modified.
The R column contains a % for buffers that are read-only."
  (interactive (list (if current-prefix-arg t nil)))
  (let ((pop-up-windows t))
    (display-buffer (list-buffers-noselect files-only) nil (selected-frame))))


(defun default-list-buffers-identification (output)
  (let ((file (or (buffer-file-name (current-buffer))
		  (and (boundp 'list-buffers-directory)
		       list-buffers-directory))))
    (set-buffer output)
    (if file
	(insert file))))


(defun list-buffers-field-sizes (buf-list &optional predicate)
  "Compute the maximum size needed for the buffer name, the buffer
  size, and buffer mode for the buffer menu"
  ;; Set some reasonable minimum limits
  (let* ((buf-name-len 10)
	 (buf-size-len 4)
	 (buf-mode-len 4)
	 ;; Don't let buffer names get longer than this.  It's ugly
	 ;; and confusing if the space is really large.  Keep it
	 ;; sensible, and just allow misaligned columns.
	 (max-buf-name-len (max buf-name-len (/ (frame-width) 3))))
    (while buf-list
      (let* ((buf (car buf-list))
	     (name (buffer-name buf))
	     name-len)
	(cond ((null name)
	       ;; Ignore deleted buffers
	       )
	      ((and predicate
		    (not (if (stringp predicate)
			     (string-match predicate name)
			   (funcall predicate buf))))
	       ;; Ignore buffers that match the predicate
	       nil)
	      (t
	       (set-buffer buf)
	       ;; Get the right length for the buffer
	       (if (string-match "[\n\"\\ \t]" name)
		   (let ((print-escape-newlines t))
		     (setq name-len (length (prin1-to-string name))))
		 (setq name-len (length name)))
	       (setq buf-name-len (max buf-name-len name-len))
	       (setq buf-size-len (max buf-size-len
				       (length (prin1-to-string (buffer-size buf)))))
	       (setq buf-mode-len (max buf-mode-len (length mode-name)))))
	(setq buf-list (cdr buf-list))))
    (list (min buf-name-len max-buf-name-len)
	  buf-size-len buf-mode-len)))

(defun list-buffers-internal (output &optional predicate)
  (let ((current (current-buffer))
        (buffers (if buffers-menu-sort-function
		     (sort (buffer-list) buffers-menu-sort-function)
		   (buffer-list)))
	format-long)

    (save-excursion
      (destructuring-bind (buf-name-len buf-size-len buf-mode-len)
	  (list-buffers-field-sizes buffers predicate)
	(setq format-long (format "%%c%%c%%c %%-%ds %%%ds %%-%ds "
				  buf-name-len buf-size-len buf-mode-len))
	(set-buffer output)
	(setq buffer-read-only nil)
	(erase-buffer)
	(buffer-disable-undo output)
	(insert (format format-long ?\ ?M ?R "Buffer" "Size" "Mode"))
	(insert "File\n")
	(insert (format format-long ?\ ?- ?- "------" "----" "----"))
	(insert "----\n")
	(goto-char (point-max))
	
	(while buffers
	  (let* ((buffer (car buffers))
		 (name (buffer-name buffer))
		 this-buffer-line-start)
	    (setq buffers (cdr buffers))
	    (cond  ((null name))		;deleted buffer
		  ((and predicate
			(not (if (stringp predicate)
				 (string-match predicate name)
                               (funcall predicate buffer))))
		   nil)
		  (t
		   (set-buffer buffer)
		   (let* ((ro buffer-read-only)
			 (id list-buffers-identification)
			 (mark-current (if (eq buffer current)
					   (progn
					     (setq current (point))
					     ?\>)
					 ?\ ))
			 (mark-modified (if (buffer-modified-p buffer)
					    ?\* ?\ ))
			 (mark-ro (if ro ?\% ?\ ))
			 (buf-mode mode-name)
			 buf-name)
		     (set-buffer output)
		     (setq this-buffer-line-start (point))
		     (if (string-match "[\n\"\\ \t]" name)
			 (let ((print-escape-newlines t))
			   (setq buf-name (prin1-to-string name)))
		       (setq buf-name name))
		     (insert (format format-long
				     mark-current mark-modified mark-ro
				     buf-name
				     (prin1-to-string (buffer-size buffer))
				     buf-mode))
		     (cond ((stringp id)
			    (insert id))
			   (id
			    (set-buffer buffer)
			    (condition-case e
				(funcall id output)
			      (error
			       (princ "***" output) (prin1 e output)))
			    (set-buffer output)
			    (goto-char (point-max)))))
		   (put-nonduplicable-text-property this-buffer-line-start
						    (point)
						    'buffer-name name)
		   (put-nonduplicable-text-property this-buffer-line-start
						    (point)
						    'highlight t)
		   (insert ?\n)))))

	(Buffer-menu-mode)
	(if (not (bufferp current))
	    (goto-char current))))))

(provide 'rlt-list-buffers)

--Multipart_Sun_Feb_16_16:56:01_1997-1
Content-Type: text/plain; charset=US-ASCII



--Multipart_Sun_Feb_16_16:56:01_1997-1--

