Mercurial > emacs

--- a/lisp/bs.el	Tue Oct 16 03:28:43 2007 +0000
+++ b/lisp/bs.el	Tue Oct 16 10:38:53 2007 +0000
@@ -158,7 +158,7 @@
     (""       2   2 left  "  ")
     ("File"   12 12 left  bs--get-file-name)
     (""       2   2 left  "  "))
-  "*List specifying the layout of a Buffer Selection Menu buffer.
+  "List specifying the layout of a Buffer Selection Menu buffer.
 Each entry specifies a column and is a list of the form of:
 \(HEADER MINIMUM-LENGTH MAXIMUM-LENGTH ALIGNMENT FUN-OR-STRING)

@@ -180,12 +180,7 @@

 (defun bs--make-header-match-string ()
   "Return a regexp matching the first line of a Buffer Selection Menu buffer."
-  (let ((res "^\\(")
-	(ele bs-attributes-list))
-    (while ele
-      (setq res (concat res (car (car ele)) " *"))
-      (setq ele (cdr ele)))
-    (concat res "$\\)")))
+  (concat "^\\(" (mapconcat #'car bs-attributes-list " *") " *$\\)"))

 ;; Font-Lock-Settings
 (defvar bs-mode-font-lock-keywords
@@ -206,7 +201,7 @@
   "Default font lock expressions for Buffer Selection Menu.")

 (defcustom bs-max-window-height 20
-  "*Maximal window height of Buffer Selection Menu."
+  "Maximal window height of Buffer Selection Menu."
   :group 'bs-appearance
   :type 'integer)

@@ -224,7 +219,7 @@
 that must always be shown regardless of the configuration.")

 (defcustom bs-must-always-show-regexp nil
-  "*Regular expression for specifying buffers to show always.
+  "Regular expression for specifying buffers to show always.
 A buffer whose name matches this regular expression will
 be shown regardless of current configuration of Buffer Selection Menu."
   :group 'bs
@@ -246,7 +241,7 @@
 It must return non-nil if the first buffer should sort before the second.")

 (defcustom bs-maximal-buffer-name-column 45
-  "*Maximum column width for buffer names.
+  "Maximum column width for buffer names.
 The column for buffer names has dynamic width.  The width depends on
 maximal and minimal length of names of buffers to show.  The maximal
 width is bounded by `bs-maximal-buffer-name-column'.
@@ -255,7 +250,7 @@
   :type 'integer)

 (defcustom bs-minimal-buffer-name-column 15
-  "*Minimum column width for buffer names.
+  "Minimum column width for buffer names.
 The column for buffer names has dynamic width.  The width depends on
 maximal and minimal length of names of buffers to show.  The minimal
 width is bounded by `bs-minimal-buffer-name-column'.
@@ -272,7 +267,7 @@
     ("files-and-scratch" "^\\*scratch\\*$" nil nil bs-visits-non-file
      bs-sort-buffer-interns-are-last)
     ("all-intern-last" nil nil nil nil bs-sort-buffer-interns-are-last))
-  "*List of all configurations you can use in the Buffer Selection Menu.
+  "List of all configurations you can use in the Buffer Selection Menu.
 A configuration describes which buffers appear in Buffer Selection Menu
 and also the order of buffers.  A configuration is a list with
 six elements.  The first element is a string and describes the configuration.
@@ -284,7 +279,7 @@
   :type '(repeat sexp))

 (defcustom bs-default-configuration "files"
-  "*Name of default configuration used by the Buffer Selection Menu.
+  "Name of default configuration used by the Buffer Selection Menu.
 \\<bs-mode-map>
 Will be changed using key \\[bs-select-next-configuration].
 Must be a string used in `bs-configurations' for naming a configuration."
@@ -292,7 +287,7 @@
   :type 'string)

 (defcustom bs-alternative-configuration "all"
-  "*Name of configuration used when calling `bs-show' with \
+  "Name of configuration used when calling `bs-show' with \
 \\[universal-argument] as prefix key.
 Must be a string used in `bs-configurations' for naming a configuration."
   :group 'bs
@@ -303,7 +298,7 @@
 Must be a string used in `bs-configurations' for naming a configuration.")

 (defcustom bs-cycle-configuration-name nil
-  "*Name of configuration used when cycling through the buffer list.
+  "Name of configuration used when cycling through the buffer list.
 A value of nil means to use current configuration `bs-default-configuration'.
 Must be a string used in `bs-configurations' for naming a configuration."
   :group 'bs
@@ -311,32 +306,32 @@
    string))

 (defcustom bs-string-show-always "+"
-  "*String added in column 1 indicating a buffer will always be shown."
+  "String added in column 1 indicating a buffer will always be shown."
   :group 'bs-appearance
   :type 'string)

 (defcustom bs-string-show-never "-"
-  "*String added in column 1 indicating a buffer will never be shown."
+  "String added in column 1 indicating a buffer will never be shown."
   :group 'bs-appearance
   :type 'string)

 (defcustom bs-string-current "."
-  "*String added in column 1 indicating the current buffer."
+  "String added in column 1 indicating the current buffer."
   :group 'bs-appearance
   :type 'string)

 (defcustom bs-string-current-marked "#"
-  "*String added in column 1 indicating the current buffer when it is marked."
+  "String added in column 1 indicating the current buffer when it is marked."
   :group 'bs-appearance
   :type 'string)

 (defcustom bs-string-marked ">"
-  "*String added in column 1 indicating a marked buffer."
+  "String added in column 1 indicating a marked buffer."
   :group 'bs-appearance
   :type 'string)

 (defcustom bs-string-show-normally  " "
-  "*String added in column 1 indicating an unmarked buffer."
+  "String added in column 1 indicating an unmarked buffer."
   :group 'bs-appearance
   :type 'string)

@@ -390,7 +385,7 @@
     ("by mode"     bs--sort-by-mode     "Mode"   region)
     ("by filename" bs--sort-by-filename "File"   region)
     ("by nothing"  nil                  nil      nil))
-  "*List of all possible sorting aspects for Buffer Selection Menu.
+  "List of all possible sorting aspects for Buffer Selection Menu.
 You can add a new entry with a call to `bs-define-sort-function'.
 Each element is a list of four elements (NAME FUNCTION REGEXP-FOR-SORTING FACE).
 NAME specifies the sort order defined by function FUNCTION.
@@ -425,7 +420,7 @@
 This is an element of `bs-sort-functions'.")

 (defcustom bs-default-sort-name "by nothing"
-  "*Name of default sort behavior.
+  "Name of default sort behavior.
 Must be \"by nothing\" or a string used in `bs-sort-functions' for
 naming a sort behavior.  Default is \"by nothing\" which means no sorting."
   :group 'bs
@@ -445,7 +440,6 @@

 (defvar bs--window-config-coming-from nil
   "Window configuration before starting Buffer Selection Menu.")
-(make-variable-frame-local 'bs--window-config-coming-from)

 (defvar bs--intern-show-never "^ \\|\\*buffer-selection\\*"
   "Regular expression specifying which buffers never to show.
@@ -529,45 +523,43 @@
   (setq sort-description (or sort-description bs--current-sort-function)
 	list (or list (buffer-list)))
   (let ((result nil))
-    (while list
-      (let* ((buffername (buffer-name (car list)))
-	     (int-show-never (string-match bs--intern-show-never buffername))
+    (dolist (buf list)
+      (let* ((buffername (buffer-name buf))
+	     (int-show-never (string-match-p bs--intern-show-never buffername))
 	     (ext-show-never (and bs-dont-show-regexp
-				  (string-match bs-dont-show-regexp
-						buffername)))
+				  (string-match-p bs-dont-show-regexp
+						  buffername)))
 	     (extern-must-show (or (and bs-must-always-show-regexp
-					(string-match
+					(string-match-p
 					 bs-must-always-show-regexp
 					 buffername))
 				   (and bs-must-show-regexp
-					(string-match bs-must-show-regexp
-						      buffername))))
+					(string-match-p bs-must-show-regexp
+							buffername))))
 	     (extern-show-never-from-fun (and bs-dont-show-function
 					      (funcall bs-dont-show-function
-						       (car list))))
+						       buf)))
 	     (extern-must-show-from-fun (and bs-must-show-function
 					     (funcall bs-must-show-function
-						      (car list))))
-	     (show-flag (buffer-local-value 'bs-buffer-show-mark (car list))))
-	(if (or (eq show-flag 'always)
-		(and (or bs--show-all (not (eq show-flag 'never)))
-		     (not int-show-never)
-		     (or bs--show-all
-			 extern-must-show
-			 extern-must-show-from-fun
-			 (and (not ext-show-never)
-			      (not extern-show-never-from-fun)))))
-	    (setq result (cons (car list)
-			       result)))
-	(setq list (cdr list))))
+						      buf)))
+	     (show-flag (buffer-local-value 'bs-buffer-show-mark buf)))
+	(when (or (eq show-flag 'always)
+		  (and (or bs--show-all (not (eq show-flag 'never)))
+		       (not int-show-never)
+		       (or bs--show-all
+			   extern-must-show
+			   extern-must-show-from-fun
+			   (and (not ext-show-never)
+				(not extern-show-never-from-fun)))))
+	  (setq result (cons buf result)))))
     (setq result (reverse result))
     ;; The current buffer which was the start point of bs should be an element
     ;; of result list, so that we can leave with space and be back in the
     ;; buffer we started bs-show.
-    (if (and bs--buffer-coming-from
-	     (buffer-live-p bs--buffer-coming-from)
-	     (not (memq bs--buffer-coming-from result)))
-	(setq result (cons bs--buffer-coming-from result)))
+    (when (and bs--buffer-coming-from
+	       (buffer-live-p bs--buffer-coming-from)
+	       (not (memq bs--buffer-coming-from result)))
+      (setq result (cons bs--buffer-coming-from result)))
     ;; sorting
     (if (and sort-description
 	     (nth 1 sort-description))
@@ -587,8 +579,8 @@
 SORT-DESCRIPTION is an element of `bs-sort-functions'."
   (let ((line (1+ (count-lines 1 (point)))))
     (bs-show-in-buffer (bs-buffer-list nil sort-description))
-    (if keep-line-p
-	(goto-line line))
+    (when keep-line-p
+      (goto-line line))
     (beginning-of-line)))

 (defun bs--goto-current-buffer ()
@@ -602,10 +594,10 @@
 	point)
     (save-excursion
       (goto-char (point-min))
-      (if (search-forward-regexp regexp nil t)
-	  (setq point (- (point) 1))))
-    (if point
-	(goto-char point))))
+      (when (search-forward-regexp regexp nil t)
+	(setq point (1- (point)))))
+    (when point
+      (goto-char point))))

 (defun bs--current-config-message ()
   "Return a string describing the current `bs-mode' configuration."
@@ -614,7 +606,23 @@
     (format "Show buffer by configuration %S"
 	    bs-current-configuration)))

-(defun bs-mode ()
+(defun bs--track-window-changes (frame)
+  "Track window changes to refresh the buffer list.
+Used from `window-size-change-functions'."
+  (let ((win (get-buffer-window "*buffer-selection*" frame)))
+    (when win
+      (with-selected-window win
+	(bs-refresh)
+	(bs--set-window-height)))))
+
+(defun bs--remove-hooks ()
+  "Remove `bs--track-window-changes' and auxiliary hooks."
+  (remove-hook 'window-size-change-functions 'bs--track-window-changes)
+  ;; Remove itself
+  (remove-hook 'kill-buffer-hook 'bs--remove-hooks t)
+  (remove-hook 'change-major-mode-hook 'bs--remove-hooks t))
+
+(define-derived-mode bs-mode nil "Buffer-Selection-Menu"
   "Major mode for editing a subset of Emacs' buffers.
 \\<bs-mode-map>
 Aside from two header lines each line describes one buffer.
@@ -647,27 +655,27 @@
 to show always.
 \\[bs-visit-tags-table] -- call `visit-tags-table' on current line's buffer.
 \\[bs-help] -- display this help text."
-  (interactive)
-  (kill-all-local-variables)
-  (use-local-map bs-mode-map)
   (make-local-variable 'font-lock-defaults)
   (make-local-variable 'font-lock-verbose)
   (make-local-variable 'font-lock-global-modes)
   (buffer-disable-undo)
-  (setq major-mode 'bs-mode
-	mode-name "Buffer-Selection-Menu"
-	buffer-read-only t
+  (setq buffer-read-only t
 	truncate-lines t
 	show-trailing-whitespace nil
 	font-lock-global-modes '(not bs-mode)
 	font-lock-defaults '(bs-mode-font-lock-keywords t)
 	font-lock-verbose nil)
-  (run-mode-hooks 'bs-mode-hook))
+  (add-hook 'window-size-change-functions 'bs--track-window-changes)
+  (add-hook 'kill-buffer-hook 'bs--remove-hooks nil t)
+  (add-hook 'change-major-mode-hook 'bs--remove-hooks nil t))

 (defun bs--restore-window-config ()
   "Restore window configuration on the current frame."
   (when bs--window-config-coming-from
-    (set-window-configuration bs--window-config-coming-from)
+    (let ((frame (selected-frame)))
+      (unwind-protect
+	   (set-window-configuration bs--window-config-coming-from)
+	(select-frame frame)))
     (setq bs--window-config-coming-from nil)))

 (defun bs-kill ()
@@ -705,8 +713,8 @@
   (beginning-of-line)
   (let ((line (+ (- bs-header-lines-length)
 		 (count-lines 1 (point)))))
-    (if (< line 0)
-	(error "You are on a header row"))
+    (when (< line 0)
+      (error "You are on a header row"))
     (nth line bs-current-list)))

 (defun bs--update-current-line ()
@@ -736,19 +744,18 @@
     (bury-buffer (current-buffer))
     (bs--restore-window-config)
     (switch-to-buffer buffer)
-    (if bs--marked-buffers
-	;; Some marked buffers for selection
-	(let* ((all (delq buffer bs--marked-buffers))
-	       (height (/ (1- (frame-height)) (1+ (length all)))))
-	  (delete-other-windows)
-	  (switch-to-buffer buffer)
-	  (while all
-	    (split-window nil height)
-	    (other-window 1)
-	    (switch-to-buffer (car all))
-	    (setq all (cdr all)))
-	  ;; goto window we have started bs.
-	  (other-window 1)))))
+    (when bs--marked-buffers
+      ;; Some marked buffers for selection
+      (let* ((all (delq buffer bs--marked-buffers))
+	     (height (/ (1- (frame-height)) (1+ (length all)))))
+	(delete-other-windows)
+	(switch-to-buffer buffer)
+	(dolist (buf all)
+	  (split-window nil height)
+	  (other-window 1)
+	  (switch-to-buffer buf))
+	;; goto window we have started bs.
+	(other-window 1)))))

 (defun bs-select-other-window ()
   "Select current line's buffer by `switch-to-buffer-other-window'.
@@ -912,11 +919,10 @@
     (delete-region (point) (save-excursion
 			     (end-of-line)
 			     (if (eobp) (point) (1+ (point)))))
-    (if (eobp)
-	(progn
-	  (backward-delete-char 1)
-	  (beginning-of-line)
-	  (recenter -1)))
+    (when (eobp)
+      (backward-delete-char 1)
+      (beginning-of-line)
+      (recenter -1))
     (bs--set-window-height)))

 (defun bs-delete-backward ()
@@ -945,14 +951,14 @@
 			      bs--current-sort-function)))
     (save-excursion
       (goto-char (point-min))
-      (if (and (nth 2 sort-description)
-	       (search-forward-regexp (nth 2 sort-description) nil t))
-	  (let ((inhibit-read-only t))
-	    (put-text-property (match-beginning 0)
-			       (match-end 0)
-			       'face
-			       (or (nth 3 sort-description)
-				   'region)))))))
+      (when (and (nth 2 sort-description)
+		 (search-forward-regexp (nth 2 sort-description) nil t))
+	(let ((inhibit-read-only t))
+	  (put-text-property (match-beginning 0)
+			     (match-end 0)
+			     'face
+			     (or (nth 3 sort-description)
+				 'region)))))))

 (defun bs-toggle-show-all ()
   "Toggle show all buffers / show buffers with current configuration."
@@ -983,10 +989,8 @@

 (defun bs--nth-wrapper (count fun &rest args)
   "Call COUNT times function FUN with arguments ARGS."
-  (setq count (or count 1))
-  (while (> count 0)
-    (apply fun args)
-    (setq count (1- count))))
+  (dotimes (i (or count 1))
+    (apply fun args)))

 (defun bs-up (arg)
   "Move cursor vertically up ARG lines in Buffer Selection Menu."
@@ -1026,7 +1030,7 @@

 (defun bs-sort-buffer-interns-are-last (b1 b2)
   "Function for sorting internal buffers at the end of all buffers."
-  (string-match "^\\*" (buffer-name b2)))
+  (string-match-p "^\\*" (buffer-name b2)))

 ;; ----------------------------------------------------------------------
 ;; Configurations:
@@ -1108,8 +1112,8 @@
 	(length (length list))
 	pos)
     (while (and assocs (not pos))
-      (if (string= (car (car assocs)) start-name)
-	  (setq pos (- length (length assocs))))
+      (when (string= (car (car assocs)) start-name)
+	(setq pos (- length (length assocs))))
       (setq assocs (cdr assocs)))
     (setq pos (1+ pos))
     (if (eq pos length)
@@ -1151,10 +1155,9 @@
     (erase-buffer)
     (setq bs--name-entry-length name-entry-length)
     (bs--show-header)
-    (while list
-      (bs--insert-one-entry (car list))
-      (insert "\n")
-      (setq list (cdr list)))
+    (dolist (buffer list)
+      (bs--insert-one-entry buffer)
+      (insert "\n"))
     (delete-backward-char 1)
     (bs--set-window-height)
     (bs--goto-current-buffer)
@@ -1348,27 +1351,21 @@
 and evaluates corresponding string.  Inserts string in current buffer;
 normally *buffer-selection*."
   (let ((string "")
-	(columns bs-attributes-list)
 	(to-much 0)
         (apply-args (append (list bs--buffer-coming-from bs-current-list))))
     (save-excursion
-      (while columns
-	(set-buffer buffer)
-	(let ((min   (bs--get-value (nth 1 (car columns))))
-	      ;;(max   (bs--get-value (nth 2 (car columns)))) refered no more
-	      (align (nth 3 (car columns)))
-	      (fun   (nth 4 (car columns)))
-	      (val   nil)
-	      new-string)
-	  (setq val (bs--get-value fun apply-args))
-	  (setq new-string (bs--format-aux val align (- min to-much)))
+      (set-buffer buffer)
+      (dolist (column bs-attributes-list)
+	(let* ((min (bs--get-value (nth 1 column)))
+	       (new-string (bs--format-aux (bs--get-value (nth 4 column) ; fun
+							  apply-args)
+					   (nth 3 column)                ; align
+					   (- min to-much)))
+	       (len (length new-string)))
 	  (setq string (concat string new-string))
-	  (if (> (length new-string) min)
-	      (setq to-much (- (length new-string) min)))
-	  )				; let
-	(setq columns (cdr columns))))
-    (insert string)
-    string))
+	  (when (> len min)
+	    (setq to-much (- len min))))))
+    (insert string)))

 (defun bs--format-aux (string align len)
   "Pad STRING to length LEN with alignment ALIGN.
@@ -1382,28 +1379,26 @@

 (defun bs--show-header ()
   "Insert header for Buffer Selection Menu in current buffer."
-  (dolist (string (bs--create-header))
-    (insert string "\n")))
+  (insert (bs--create-header-line #'identity)
+	  "\n"
+	  (bs--create-header-line (lambda (title)
+				    (make-string (length title) ?-)))
+	  "\n"))

 (defun bs--get-name-length ()
   "Return value of `bs--name-entry-length'."
   bs--name-entry-length)

-(defun bs--create-header ()
-  "Return all header lines used in Buffer Selection Menu as a list of strings."
-  (list (mapconcat (lambda (column)
-		     (bs--format-aux (bs--get-value (car column))
-				     (nth 3 column) ; align
-				     (bs--get-value (nth 1 column))))
-		   bs-attributes-list
-		   "")
-	(mapconcat (lambda (column)
-		     (let ((length (length (bs--get-value (car column)))))
-		       (bs--format-aux (make-string length ?-)
-				       (nth 3 column) ; align
-				       (bs--get-value (nth 1 column)))))
-		   bs-attributes-list
-		   "")))
+(defun bs--create-header-line (col)
+  "Generate a line for the header.
+COL is called for each column in `bs-attributes-list' as a
+function of one argument, the string heading for the column."
+  (mapconcat (lambda (column)
+	       (bs--format-aux (funcall col (bs--get-value (car column)))
+			       (nth 3 column) ; align
+			       (bs--get-value (nth 1 column))))
+	     bs-attributes-list
+	     ""))

 (defun bs--show-with-configuration (name &optional arg)
   "Display buffer list of configuration with name NAME.
@@ -1424,14 +1419,14 @@
       (setq bs--buffer-coming-from (current-buffer)))
     (let ((liste (bs-buffer-list))
 	  (active-window (get-window-with-predicate
-                          (lambda (w)
-                            (string= (buffer-name (window-buffer w))
-                                     "*buffer-selection*")))))
+			  (lambda (w)
+			    (string= (buffer-name (window-buffer w))
+				     "*buffer-selection*"))
+			  nil (selected-frame))))
       (if active-window
 	  (select-window active-window)
-        (modify-frame-parameters nil
-                                 (list (cons 'bs--window-config-coming-from
-                                             (current-window-configuration))))
+	(bs--restore-window-config)
+	(setq bs--window-config-coming-from (current-window-configuration))
 	(when (> (window-height (selected-window)) 7)
           (split-window-vertically)
           (other-window 1)))