X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/5762abecd390e960b2a15bc58b5ed6a07af5955f..a12ca05478f3eb4429a1038699f5dad682f4056d:/lisp/msb.el

diff --git a/lisp/msb.el b/lisp/msb.el
index cb1706fdf7..7eb2633837 100644
--- a/lisp/msb.el
+++ b/lisp/msb.el
@@ -1,6 +1,7 @@
-;;; msb.el --- Customizable buffer-selection with multiple menus.
+;;; msb.el --- customizable buffer-selection with multiple menus
 
-;; Copyright (C) 1993, 94, 95, 97, 98, 99 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 94, 95, 97, 98, 99, 2000, 2001
+;;  Free Software Foundation, Inc.
 
 ;; Author: Lars Lindberg <Lars.G.Lindberg@capgemini.se>
 ;; Maintainer: FSF
@@ -108,16 +109,12 @@
     ((eq major-mode 'w3-mode)
      4020
      "WWW (%d)")
-    ((or (memq major-mode '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode))
-	 (memq major-mode '(mh-letter-mode
-			    mh-show-mode
-			    mh-folder-mode))
-	 (memq major-mode '(gnus-summary-mode
-			    news-reply-mode
-			    gnus-group-mode
-			    gnus-article-mode
-			    gnus-kill-file-mode
-			    gnus-browse-killed-mode)))
+    ((or (memq major-mode
+	       '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode))
+	 (memq major-mode '(mh-letter-mode mh-show-mode mh-folder-mode))
+	 (memq major-mode
+	       '(gnus-summary-mode message-mode gnus-group-mode
+	         gnus-article-mode score-mode gnus-browse-killed-mode)))
      4010
      "Mail (%d)")
     ((not buffer-file-name)
@@ -163,15 +160,11 @@
     ((eq major-mode 'w3-mode)
      5020
      "WWW (%d)")
-    ((or (memq major-mode '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode))
-	 (memq major-mode '(mh-letter-mode
-			    mh-show-mode
-			    mh-folder-mode))
-	 (memq major-mode '(gnus-summary-mode
-			    news-reply-mode
-			    gnus-group-mode
-			    gnus-article-mode
-			    gnus-kill-file-mode
+    ((or (memq major-mode
+	       '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode))
+	 (memq major-mode '(mh-letter-mode mh-show-mode mh-folder-mode))
+	 (memq major-mode '(gnus-summary-mode message-mode gnus-group-mode
+			    gnus-article-mode score-mode
 			    gnus-browse-killed-mode)))
      5010
      "Mail (%d)")
@@ -209,19 +202,6 @@
   :prefix "msb-"
   :group 'mouse)
 
-;;;###autoload
-(defcustom msb-mode nil
-  "Toggle msb-mode.
-Setting this variable directly does not take effect;
-use either \\[customize] or the function `msb-mode'."
-  :set (lambda (symbol value)
-	 (msb-mode (or value 0)))
-  :initialize 'custom-initialize-default
-  :version "20.4"
-  :type    'boolean
-  :group   'msb
-  :require 'msb)
-
 (defun msb-custom-set (symbol value)
   "Set the value of custom variables for msb."
   (set symbol value)
@@ -276,7 +256,8 @@ Note2: A buffer menu appears only if it has at least one buffer in it.
 Note3: If you have a CONDITION that can't be evaluated you will get an
 error every time you do \\[msb]."
   :type `(choice (const :tag "long" :value ,msb--very-many-menus)
-		 (const :tag "short" :value ,msb--few-menus))
+		 (const :tag "short" :value ,msb--few-menus)
+		 (sexp :tag "user"))
   :set 'msb-custom-set
   :group 'msb)
 
@@ -380,8 +361,7 @@ Set this to nil or t if you don't want any sorting (faster)."
 		 (const :tag "Newest first" t)
 		 (const :tag "Oldest first" nil))
   :set 'msb-custom-set
-  :group 'msb
-)
+  :group 'msb)
 		
 (defcustom msb-files-by-directory nil
   "*Non-nil means that files should be sorted by directory.
@@ -390,8 +370,8 @@ This is instead of the groups in `msb-menu-cond'."
   :set 'msb-custom-set
   :group 'msb)
 
-(defcustom msb-after-load-hooks nil
-  "Hooks to be run after the msb package has been loaded."
+(defcustom msb-after-load-hook nil
+  "Hook run after the msb package has been loaded."
   :type 'hook
   :set 'msb-custom-set
   :group 'msb)
@@ -523,37 +503,41 @@ If the argument is left out or nil, then the current buffer is considered."
 	 ;; Make alist that looks like
 	 ;; ((PATH-1 BUFFER-1) (PATH-2 BUFFER-2) ...)
 	 ;; sorted on PATH-x
-	 (sort (mapcan
-		(lambda (buffer)
-		  (let ((file-name (expand-file-name (buffer-file-name buffer))))
-		    (when file-name
-		      (list (cons (msb--strip-dir file-name) buffer)))))
-		list)
-	       (lambda (item1 item2)
-		 (string< (car item1) (car item2))))))
+	 (sort
+	  (apply #'nconc
+		 (mapcar
+		  (lambda (buffer)
+		    (let ((file-name (expand-file-name
+				      (buffer-file-name buffer))))
+		      (when file-name
+			(list (cons (msb--strip-dir file-name) buffer)))))
+		  list))
+	  (lambda (item1 item2)
+	    (string< (car item1) (car item2))))))
     ;; Now clump buffers together that have the same path
     ;; Make alist that looks like
     ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K)) ...)
     (let ((path nil)
 	  (buffers nil))
       (nconc
-       (mapcan (lambda (item)
-		 (cond
-		  ((and path
-			(string= path (car item)))
-		   ;; The same path as earlier: Add to current list of
-		   ;; buffers.
-		   (push (cdr item) buffers)
-		   ;; This item should not be added to list
-		   nil)
-		  (t
-		   ;; New path
-		   (let ((result (and path (cons path buffers))))
-		     (setq path (car item))
-		     (setq buffers (list (cdr item)))
-		     ;; Add the last result the list.
-		     (and result (list result))))))
-	       buffer-alist)
+       (apply
+	#'nconc
+	(mapcar (lambda (item)
+		  (cond
+		   ((equal path (car item))
+		    ;; The same path as earlier: Add to current list of
+		    ;; buffers.
+		    (push (cdr item) buffers)
+		    ;; This item should not be added to list
+		    nil)
+		   (t
+		    ;; New path
+		    (let ((result (and path (cons path buffers))))
+		      (setq path (car item))
+		      (setq buffers (list (cdr item)))
+		      ;; Add the last result the list.
+		      (and result (list result))))))
+		buffer-alist))
        ;; Add the last result to the list
        (list (cons path buffers))))))
 
@@ -582,7 +566,7 @@ If the argument is left out or nil, then the current buffer is considered."
 	  rest (cdr buffer-alist)
 	  path (car first)
 	  buffers (cdr first))
-    (setq msb--choose-file-menu-list (copy-list rest))
+    (setq msb--choose-file-menu-list (copy-sequence rest))
     ;; This big loop tries to clump buffers together that have a
     ;; similar name. Remember that buffer-alist is sorted based on the
     ;; path for the buffers.
@@ -597,8 +581,11 @@ If the argument is left out or nil, then the current buffer is considered."
 	(while (and tmp-rest
 		    (<= (length buffers) max-clumped-together)
 		    (>= (length (car item)) (length path))
+		    ;; `completion-ignore-case' seems to default to t
+		    ;; on the systems with case-insensitive file names.
 		    (eq t (compare-strings path 0 nil
-					   (car item) 0 (length path))))
+					   (car item) 0 (length path)
+					   completion-ignore-case)))
 	  (setq found-p t)
 	  (setq buffers (append buffers (cdr item))) ;nconc is faster than append
 	  (setq tmp-rest (cdr tmp-rest)
@@ -636,13 +623,14 @@ If the argument is left out or nil, then the current buffer is considered."
 	      (setq last-path path))
 	  (when (and last-path
 		     (or (and (>= (length path) (length last-path))
-			      (eq t (compare-strings last-path 0 nil
-						     path 0 (length
-							     last-path))))
+			      (eq t (compare-strings
+				     last-path 0 nil path 0
+				     (length last-path)
+				     completion-ignore-case)))
 			 (and (< (length path) (length last-path))
-			      (eq t (compare-strings path 0 nil
-						     last-path 0 (length
-								  path))))))
+			      (eq t (compare-strings
+				     path 0 nil last-path 0 (length path)
+				     completion-ignore-case)))))
 	    ;; We have reached the same place in the file hierarchy as
 	    ;; the last result, so we should quit at this point and
 	    ;; take what we have as result.
@@ -683,7 +671,7 @@ See `msb-menu-cond' for a description of its elements."
 	 (sorter (if (or (fboundp tmp-s)
 			 (null tmp-s)
 			 (eq tmp-s t))
-		    tmp-s
+		     tmp-s
 		   msb-item-sort-function)))
     (when (< (length menu-cond-elt) 3)
       (error "Wrong format of msb-menu-cond"))
@@ -752,9 +740,8 @@ to the buffer-list variable in function-info."
 	(save-excursion
 	  (set-buffer buffer)
 	  ;; Menu found.  Add to this menu
-	  (mapc (lambda (function-info)
-		  (msb--add-to-menu buffer function-info max-buffer-name-length))
-		(msb--collect function-info-vector)))
+	  (dolist (info (msb--collect function-info-vector))
+	    (msb--add-to-menu buffer info max-buffer-name-length)))
       (error (unless msb--error
 	       (setq msb--error
 		     (format
@@ -788,13 +775,13 @@ SAME-PREDICATE) are aggregated together.  The alist is first sorted by
 SORT-PREDICATE.
 
 Example:
-(msb--aggregate-alist
+\(msb--aggregate-alist
  '((a . a1) (a . a2) (b . b1) (c . c3) (a . a4) (a . a3) (b . b3) (b . b2))
  (function string=)
  (lambda (item1 item2)
    (string< (symbol-name item1) (symbol-name item2))))
 results in
-((a a1 a2 a4 a3) (b b1 b3 b2) (c c3))"
+\((a a1 a2 a4 a3) (b b1 b3 b2) (c c3))"
   (when (not (null alist))
     (let (result
 	  same
@@ -803,7 +790,9 @@ results in
 	  (first-time-p t)
 	  old-car)
       (nconc
-       (mapcan (lambda (item)
+       (apply #'nconc
+	      (mapcar
+	       (lambda (item)
 		 (cond
 		  (first-time-p
 		   (push (cdr item) same)
@@ -820,7 +809,7 @@ results in
 			 old-car (car item))
 		   (list (cons tmp-old-car (nreverse tmp-same))))))
 	       (sort alist (lambda (item1 item2)
-			     (funcall sort-predicate (car item1) (car item2)))))
+			     (funcall sort-predicate (car item1) (car item2))))))
        (list (cons old-car (nreverse same)))))))
 
 
@@ -833,14 +822,13 @@ results in
 		    (concat (cdr item) " (%d)")))
 	    (sort
 	     (let ((mode-list nil))
-	       (mapc (lambda (buffer)
-		       (save-excursion
-			 (set-buffer buffer)
-			 (when (and (not (msb-invisible-buffer-p))
-				    (not (assq major-mode mode-list))
-				    (push (cons major-mode mode-name)
-					  mode-list)))))
-		     (cdr (buffer-list)))
+	       (dolist (buffer (cdr (buffer-list)))
+		 (save-excursion
+		   (set-buffer buffer)
+		   (when (and (not (msb-invisible-buffer-p))
+			      (not (assq major-mode mode-list)))
+		     (push (cons major-mode mode-name)
+			   mode-list))))
 	       mode-list)
 	     (lambda (item1 item2)
 	       (string< (cdr item1) (cdr item2)))))))
@@ -877,14 +865,11 @@ It takes the form ((TITLE . BUFFER-LIST)...)."
 	file-buffers
 	function-info-vector)
     ;; Calculate the longest buffer name.
-    (mapc
-     (lambda (buffer)
-       (if (or msb-display-invisible-buffers-p
-	       (not (msb-invisible-buffer-p)))
-	   (setq max-buffer-name-length
-		 (max max-buffer-name-length
-		      (length (buffer-name buffer))))))
-     (buffer-list))
+    (dolist (buffer (buffer-list))
+      (when (or msb-display-invisible-buffers-p
+		(not (msb-invisible-buffer-p)))
+	(setq max-buffer-name-length
+	      (max max-buffer-name-length (length (buffer-name buffer))))))
     ;; Make a list with elements of type
     ;; (BUFFER-LIST-VARIABLE
     ;;  CONDITION
@@ -900,19 +885,18 @@ It takes the form ((TITLE . BUFFER-LIST)...)."
 			 (append msb-menu-cond (msb--mode-menu-cond)))))
     ;; Split the buffer-list into several lists; one list for each
     ;; criteria.  This is the most critical part with respect to time.
-    (mapc (lambda (buffer)
-	    (cond ((and msb-files-by-directory
-			(buffer-file-name buffer)
-			;; exclude ange-ftp buffers
-			;;(not (string-match "\\/[^/:]+:"
-			;;		   (buffer-file-name buffer)))
-			)
-		   (push buffer file-buffers))
-		  (t
-		   (msb--choose-menu buffer
-				     function-info-vector
-				     max-buffer-name-length))))
-	  (buffer-list))
+    (dolist (buffer (buffer-list))
+      (cond ((and msb-files-by-directory
+		  (buffer-file-name buffer)
+		  ;; exclude ange-ftp buffers
+		  ;;(not (string-match "\\/[^/:]+:"
+		  ;;		   (buffer-file-name buffer)))
+		  )
+	     (push buffer file-buffers))
+	    (t
+	     (msb--choose-menu buffer
+			       function-info-vector
+			       max-buffer-name-length))))
     (when file-buffers
       (setq file-buffers
 	    (mapcar (lambda (buffer-list)
@@ -966,9 +950,9 @@ It takes the form ((TITLE . BUFFER-LIST)...)."
        (list (cons 'toggle
 		   (cons
 		   (if msb-files-by-directory
-		       "*Files by type*"
-		     "*Files by directory*")
-		   'msb--toggle-menu-type)))))))
+			       "*Files by type*"
+			     "*Files by directory*")
+			   'msb--toggle-menu-type)))))))
 
 (defun msb--create-buffer-menu  ()
   (save-match-data
@@ -1018,7 +1002,8 @@ variable `msb-menu-cond'."
       (mouse-select-buffer event))
      ((and (numberp (car choice))
 	   (null (cdr choice)))
-      (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice) msb--last-buffer-menu))))
+      (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice)
+						   msb--last-buffer-menu))))
 	(mouse-select-buffer event)))
      ((while (numberp (car choice))
 	(setq choice (cdr choice))))
@@ -1032,26 +1017,25 @@ variable `msb-menu-cond'."
 
 ;; Add separators
 (defun msb--add-separators (sorted-list)
-  (cond
-   ((or (not msb-separator-diff)
-	(not (numberp msb-separator-diff)))
-    sorted-list)
-   (t
+  (if (or (not msb-separator-diff)
+	  (not (numberp msb-separator-diff)))
+      sorted-list
     (let ((last-key nil))
-      (mapcan
-       (lambda (item)
-	 (cond
-	  ((and msb-separator-diff
-		last-key
-		(> (- (car item) last-key)
-		   msb-separator-diff))
-	   (setq last-key (car item))
-	   (list (cons last-key 'separator)
-		 item))
-	  (t
-	   (setq last-key (car item))
-	   (list item))))
-       sorted-list)))))
+      (apply #'nconc
+	     (mapcar
+	      (lambda (item)
+		(cond
+		 ((and msb-separator-diff
+		       last-key
+		       (> (- (car item) last-key)
+			  msb-separator-diff))
+		  (setq last-key (car item))
+		  (list (cons last-key 'separator)
+			item))
+		 (t
+		  (setq last-key (car item))
+		  (list item))))
+	      sorted-list)))))
 
 (defun msb--split-menus-2 (list mcount result)
   (cond
@@ -1062,22 +1046,21 @@ variable `msb-menu-cond'."
       (while (< count msb-max-menu-items)
 	(push (pop list) tmp-list)
 	(incf count))
-    (setq tmp-list (nreverse tmp-list))
-    (setq sub-name (concat (car (car tmp-list)) "..."))
-    (push (nconc (list mcount sub-name
-		       'keymap sub-name)
-		  tmp-list)
-	  result))
+      (setq tmp-list (nreverse tmp-list))
+      (setq sub-name (concat (car (car tmp-list)) "..."))
+      (push (nconc (list mcount sub-name
+			 'keymap sub-name)
+		   tmp-list)
+	    result))
     (msb--split-menus-2 list (1+ mcount) result))
    ((null result)
     list)
    (t
     (let (sub-name)
       (setq sub-name (concat (car (car list)) "..."))
-      (push (nconc (list mcount sub-name
-			 'keymap sub-name)
-		  list)
-	  result))
+      (push (nconc (list mcount sub-name 'keymap sub-name)
+		   list)
+	    result))
     (nreverse result))))
 
 (defun msb--split-menus (list)
@@ -1095,12 +1078,9 @@ variable `msb-menu-cond'."
 	((eq 'separator sub-menu)
 	 (list 'separator "--"))
 	(t
-	 (let ((buffers (mapcar (function
-				 (lambda (item)
-				   (let ((string (car item))
-					 (buffer (cdr item)))
-				     (cons (buffer-name buffer)
-					   (cons string end)))))
+	 (let ((buffers (mapcar (lambda (item)
+				  (cons (buffer-name (cdr item))
+					(cons (car item) end)))
 				(cdr sub-menu))))
 	   (nconc (list (incf mcount) (car sub-menu)
 			'keymap (car sub-menu))
@@ -1152,33 +1132,30 @@ variable `msb-menu-cond'."
 ;; Snarf current bindings of `mouse-buffer-menu' (normally
 ;; C-down-mouse-1).
 (defvar msb-mode-map
-  (let ((map (make-sparse-keymap)))
-    (mapcar (lambda (key)
-	      (define-key map key #'msb))
-	    (where-is-internal 'mouse-buffer-menu (make-sparse-keymap)))
+  (let ((map (make-sparse-keymap "Msb")))
+    (substitute-key-definition 'mouse-buffer-menu 'msb map global-map)
     map))
 
 ;;;###autoload
-(defun msb-mode (&optional arg)
+(define-minor-mode msb-mode
   "Toggle Msb mode.
 With arg, turn Msb mode on if and only if arg is positive.
 This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
 different buffer menu using the function `msb'."
-  (interactive "P")
-  (setq msb-mode (if arg
-		     (> (prefix-numeric-value arg) 0)
-		   (not msb-mode)))
+  :global t
   (if msb-mode
       (progn
 	(add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
-	(remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
+	(remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
+	(msb-menu-bar-update-buffers t))
     (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
-    (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
-  (run-hooks 'menu-bar-update-hook))
+    (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
+    (menu-bar-update-buffers t)))
 
-(add-to-list 'minor-mode-map-alist (cons 'msb-mode msb-mode-map))
+(defun msb-unload-hook ()
+  (msb-mode 0))
 
 (provide 'msb)
-(eval-after-load 'msb (run-hooks 'msb-after-load-hooks))
+(eval-after-load "msb" '(run-hooks 'msb-after-load-hook 'msb-after-load-hooks))
 
 ;;; msb.el ends here