-;;; 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
;; Alon Albert <alon@milcse.rtsg.mot.com>
;; Kevin Broadey, <KevinB@bartley.demon.co.uk>
;; Ake Stenhof <ake@cadpoint.se>
-;; Richard Stallman <rms@gnu.ai.mit.edu>
+;; Richard Stallman <rms@gnu.org>
;; Steve Fisk <fisk@medved.bowdoin.edu>
-;; This version turned into a global minor mode by Dave Love.
+;; This version turned into a global minor mode and subsequently
+;; hacked on by Dave Love.
;;; Code:
-(require 'cl)
+(eval-when-compile (require 'cl))
;;;
;;; Some example constants to be used for `msb-menu-cond'. See that
((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)
((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)")
: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)
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)
(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.
: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)
;;; Internal variables
;;;
-;; Home directory for the current user
-(defconst msb--home-dir
- (condition-case nil
- (substitute-in-file-name "$HOME")
- ;; If $HOME isn't defined, use nil
- (error nil)))
-
;; The last calculated menu.
(defvar msb--last-buffer-menu nil)
;; 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))))))
(defun msb--format-title (top-found-p path number-of-items)
"Format a suitable title for the menu item."
- (let ((new-path path))
- (when (and msb--home-dir
- (string-match (concat "^" msb--home-dir) path))
- (setq new-path (concat "~"
- (substring path (match-end 0)))))
- (format (if top-found-p "%s... (%d)" "%s (%d)")
- new-path number-of-items)))
+ (format (if top-found-p "%s... (%d)" "%s (%d)")
+ (abbreviate-file-name path) number-of-items))
;; Variables for debugging.
(defvar msb--choose-file-menu-list)
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.
(while (and tmp-rest
(<= (length buffers) max-clumped-together)
(>= (length (car item)) (length path))
- (string= path (substring (car item) 0 (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)
+ completion-ignore-case)))
(setq found-p t)
(setq buffers (append buffers (cdr item))) ;nconc is faster than append
(setq tmp-rest (cdr tmp-rest)
(setq last-path path))
(when (and last-path
(or (and (>= (length path) (length last-path))
- (string= last-path
- (substring 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))
- (string= path
- (substring 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.
(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"))
(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
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
(first-time-p t)
old-car)
(nconc
- (mapcan (lambda (item)
+ (apply #'nconc
+ (mapcar
+ (lambda (item)
(cond
(first-time-p
(push (cdr item) same)
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)))))))
(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)))))))
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
(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)
(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
(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))))
;; 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
(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)
((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))
;; 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
HCoop / bpt / emacs.git / blobdiff