Fix maintainer address.
[emacs.git] / lisp / msb.el
blobcb1706fdf719934cce73e5da25a6f8e5b94fd2aa
1 ;;; msb.el --- Customizable buffer-selection with multiple menus.
3 ;; Copyright (C) 1993, 94, 95, 97, 98, 99 Free Software Foundation, Inc.
5 ;; Author: Lars Lindberg <Lars.G.Lindberg@capgemini.se>
6 ;; Maintainer: FSF
7 ;; Created: 8 Oct 1993
8 ;; Lindberg's last update version: 3.34
9 ;; Keywords: mouse buffer menu
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
28 ;;; Commentary:
30 ;; Purpose of this package:
31 ;; 1. Offer a function for letting the user choose buffer,
32 ;; not necessarily for switching to it.
33 ;; 2. Make a better mouse-buffer-menu. This is done as a global
34 ;; minor mode, msb-mode.
36 ;; Customization:
37 ;; Look at the variable `msb-menu-cond' for deciding what menus you
38 ;; want. It's not that hard to customize, despite my not-so-good
39 ;; doc-string. Feel free to send me a better doc-string.
40 ;; There are some constants for you to try here:
41 ;; msb--few-menus
42 ;; msb--very-many-menus (default)
43 ;;
44 ;; Look at the variable `msb-item-handling-function' for customization
45 ;; of the appearance of every menu item. Try for instance setting
46 ;; it to `msb-alon-item-handler'.
47 ;;
48 ;; Look at the variable `msb-item-sort-function' for customization
49 ;; of sorting the menus. Set it to t for instance, which means no
50 ;; sorting - you will get latest used buffer first.
52 ;; Also check out the variable `msb-display-invisible-buffers-p'.
54 ;; Known bugs:
55 ;; - Files-by-directory
56 ;; + No possibility to show client/changed buffers separately.
57 ;; + All file buffers only appear in a file sub-menu, they will
58 ;; for instance not appear in the Mail sub-menu.
60 ;; Future enhancements:
62 ;;; Thanks goes to
63 ;; Mark Brader <msb@sq.com>
64 ;; Jim Berry <m1jhb00@FRB.GOV>
65 ;; Hans Chalupsky <hans@cs.Buffalo.EDU>
66 ;; Larry Rosenberg <ljr@ictv.com>
67 ;; Will Henney <will@astroscu.unam.mx>
68 ;; Jari Aalto <jaalto@tre.tele.nokia.fi>
69 ;; Michael Kifer <kifer@sbkifer.cs.sunysb.edu>
70 ;; Gael Marziou <gael@gnlab030.grenoble.hp.com>
71 ;; Dave Gillespie <daveg@thymus.synaptics.com>
72 ;; Alon Albert <alon@milcse.rtsg.mot.com>
73 ;; Kevin Broadey, <KevinB@bartley.demon.co.uk>
74 ;; Ake Stenhof <ake@cadpoint.se>
75 ;; Richard Stallman <rms@gnu.org>
76 ;; Steve Fisk <fisk@medved.bowdoin.edu>
78 ;; This version turned into a global minor mode and subsequently
79 ;; hacked on by Dave Love.
80 ;;; Code:
82 (eval-when-compile (require 'cl))
84 ;;;
85 ;;; Some example constants to be used for `msb-menu-cond'. See that
86 ;;; variable for more information. Please note that if the condition
87 ;;; returns `multi', then the buffer can appear in several menus.
88 ;;;
89 (defconst msb--few-menus
90 '(((and (boundp 'server-buffer-clients)
91 server-buffer-clients
92 'multi)
93 3030
94 "Clients (%d)")
95 ((and msb-display-invisible-buffers-p
96 (msb-invisible-buffer-p)
97 'multi)
98 3090
99 "Invisible buffers (%d)")
100 ((eq major-mode 'dired-mode)
101 2010
102 "Dired (%d)"
103 msb-dired-item-handler
104 msb-sort-by-directory)
105 ((eq major-mode 'Man-mode)
106 4090
107 "Manuals (%d)")
108 ((eq major-mode 'w3-mode)
109 4020
110 "WWW (%d)")
111 ((or (memq major-mode '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode))
112 (memq major-mode '(mh-letter-mode
113 mh-show-mode
114 mh-folder-mode))
115 (memq major-mode '(gnus-summary-mode
116 news-reply-mode
117 gnus-group-mode
118 gnus-article-mode
119 gnus-kill-file-mode
120 gnus-browse-killed-mode)))
121 4010
122 "Mail (%d)")
123 ((not buffer-file-name)
124 4099
125 "Buffers (%d)")
126 ('no-multi
127 1099
128 "Files (%d)")))
130 (defconst msb--very-many-menus
131 '(((and (boundp 'server-buffer-clients)
132 server-buffer-clients
133 'multi)
134 1010
135 "Clients (%d)")
136 ((and (boundp 'vc-mode) vc-mode 'multi)
137 1020
138 "Version Control (%d)")
139 ((and buffer-file-name
140 (buffer-modified-p)
141 'multi)
142 1030
143 "Changed files (%d)")
144 ((and (get-buffer-process (current-buffer))
145 'multi)
146 1040
147 "Processes (%d)")
148 ((and msb-display-invisible-buffers-p
149 (msb-invisible-buffer-p)
150 'multi)
151 1090
152 "Invisible buffers (%d)")
153 ((eq major-mode 'dired-mode)
154 2010
155 "Dired (%d)"
156 ;; Note this different menu-handler
157 msb-dired-item-handler
158 ;; Also note this item-sorter
159 msb-sort-by-directory)
160 ((eq major-mode 'Man-mode)
161 5030
162 "Manuals (%d)")
163 ((eq major-mode 'w3-mode)
164 5020
165 "WWW (%d)")
166 ((or (memq major-mode '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode))
167 (memq major-mode '(mh-letter-mode
168 mh-show-mode
169 mh-folder-mode))
170 (memq major-mode '(gnus-summary-mode
171 news-reply-mode
172 gnus-group-mode
173 gnus-article-mode
174 gnus-kill-file-mode
175 gnus-browse-killed-mode)))
176 5010
177 "Mail (%d)")
178 ;; Catchup for all non-file buffers
179 ((and (not buffer-file-name)
180 'no-multi)
181 5099
182 "Other non-file buffers (%d)")
183 ((and (string-match "/\\.[^/]*$" buffer-file-name)
184 'multi)
185 3090
186 "Hidden Files (%d)")
187 ((memq major-mode '(c-mode c++-mode))
188 3010
189 "C/C++ Files (%d)")
190 ((eq major-mode 'emacs-lisp-mode)
191 3020
192 "Elisp Files (%d)")
193 ((eq major-mode 'latex-mode)
194 3030
195 "LaTex Files (%d)")
196 ('no-multi
197 3099
198 "Other files (%d)")))
200 ;; msb--many-menus is obsolete
201 (defvar msb--many-menus msb--very-many-menus)
204 ;;; Customizable variables
207 (defgroup msb nil
208 "Customizable buffer-selection with multiple menus."
209 :prefix "msb-"
210 :group 'mouse)
212 ;;;###autoload
213 (defcustom msb-mode nil
214 "Toggle msb-mode.
215 Setting this variable directly does not take effect;
216 use either \\[customize] or the function `msb-mode'."
217 :set (lambda (symbol value)
218 (msb-mode (or value 0)))
219 :initialize 'custom-initialize-default
220 :version "20.4"
221 :type 'boolean
222 :group 'msb
223 :require 'msb)
225 (defun msb-custom-set (symbol value)
226 "Set the value of custom variables for msb."
227 (set symbol value)
228 (if (and (featurep 'msb) msb-mode)
229 ;; wait until package has been loaded before bothering to update
230 ;; the buffer lists.
231 (msb-menu-bar-update-buffers t)))
233 (defcustom msb-menu-cond msb--very-many-menus
234 "*List of criteria for splitting the mouse buffer menu.
235 The elements in the list should be of this type:
236 (CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLING-FN ITEM-SORT-FN).
238 When making the split, the buffers are tested one by one against the
239 CONDITION, just like a Lisp cond: When hitting a true condition, the
240 other criteria are *not* tested and the buffer name will appear in the
241 menu with the menu-title corresponding to the true condition.
243 If the condition returns the symbol `multi', then the buffer will be
244 added to this menu *and* tested for other menus too. If it returns
245 `no-multi', then the buffer will only be added if it hasn't been added
246 to any other menu.
248 During this test, the buffer in question is the current buffer, and
249 the test is surrounded by calls to `save-excursion' and
250 `save-match-data'.
252 The categories are sorted by MENU-SORT-KEY. Smaller keys are on top.
253 nil means don't display this menu.
255 MENU-TITLE is really a format. If you add %d in it, the %d is
256 replaced with the number of items in that menu.
258 ITEM-HANDLING-FN, is optional. If it is supplied and is a function,
259 than it is used for displaying the items in that particular buffer
260 menu, otherwise the function pointed out by
261 `msb-item-handling-function' is used.
263 ITEM-SORT-FN, is also optional.
264 If it is not supplied, the function pointed out by
265 `msb-item-sort-function' is used.
266 If it is nil, then no sort takes place and the buffers are presented
267 in least-recently-used order.
268 If it is t, then no sort takes place and the buffers are presented in
269 most-recently-used order.
270 If it is supplied and non-nil and not t than it is used for sorting
271 the items in that particular buffer menu.
273 Note1: There should always be a `catch-all' as last element, in this
274 list. That is an element like (t TITLE ITEM-HANDLING-FUNCTION).
275 Note2: A buffer menu appears only if it has at least one buffer in it.
276 Note3: If you have a CONDITION that can't be evaluated you will get an
277 error every time you do \\[msb]."
278 :type `(choice (const :tag "long" :value ,msb--very-many-menus)
279 (const :tag "short" :value ,msb--few-menus))
280 :set 'msb-custom-set
281 :group 'msb)
283 (defcustom msb-modes-key 4000
284 "The sort key for files sorted by mode."
285 :type 'integer
286 :set 'msb-custom-set
287 :group 'msb
288 :version "20.3")
290 (defcustom msb-separator-diff 100
291 "*Non-nil means use separators.
292 The separators will appear between all menus that have a sorting key
293 that differs by this value or more."
294 :type '(choice integer (const nil))
295 :set 'msb-custom-set
296 :group 'msb)
298 (defvar msb-files-by-directory-sort-key 0
299 "*The sort key for files sorted by directory.")
301 (defcustom msb-max-menu-items 15
302 "*The maximum number of items in a menu.
303 If this variable is set to 15 for instance, then the submenu will be
304 split up in minor parts, 15 items each. Nil means no limit."
305 :type '(choice integer (const nil))
306 :set 'msb-custom-set
307 :group 'msb)
309 (defcustom msb-max-file-menu-items 10
310 "*The maximum number of items from different directories.
312 When the menu is of type `file by directory', this is the maximum
313 number of buffers that are clumped together from different
314 directories.
316 Set this to 1 if you want one menu per directory instead of clumping
317 them together.
319 If the value is not a number, then the value 10 is used."
320 :type 'integer
321 :set 'msb-custom-set
322 :group 'msb)
324 (defcustom msb-most-recently-used-sort-key -1010
325 "*Where should the menu with the most recently used buffers be placed?"
326 :type 'integer
327 :set 'msb-custom-set
328 :group 'msb)
330 (defcustom msb-display-most-recently-used 15
331 "*How many buffers should be in the most-recently-used menu.
332 No buffers at all if less than 1 or nil (or any non-number)."
333 :type 'integer
334 :set 'msb-custom-set
335 :group 'msb)
337 (defcustom msb-most-recently-used-title "Most recently used (%d)"
338 "*The title for the most-recently-used menu."
339 :type 'string
340 :set 'msb-custom-set
341 :group 'msb)
343 (defvar msb-horizontal-shift-function '(lambda () 0)
344 "*Function that specifies how many pixels to shift the top menu leftwards.")
346 (defcustom msb-display-invisible-buffers-p nil
347 "*Show invisible buffers or not.
348 Non-nil means that the buffer menu should include buffers that have
349 names that starts with a space character."
350 :type 'boolean
351 :set 'msb-custom-set
352 :group 'msb)
354 (defvar msb-item-handling-function 'msb-item-handler
355 "*The appearance of a buffer menu.
357 The default function to call for handling the appearance of a menu
358 item. It should take to arguments, BUFFER and MAX-BUFFER-NAME-LENGTH,
359 where the latter is the max length of all buffer names.
361 The function should return the string to use in the menu.
363 When the function is called, BUFFER is the current buffer. This
364 function is called for items in the variable `msb-menu-cond' that have
365 nil as ITEM-HANDLING-FUNCTION. See `msb-menu-cond' for more
366 information.")
368 (defcustom msb-item-sort-function 'msb-sort-by-name
369 "*The order of items in a buffer menu.
371 The default function to call for handling the order of items in a menu
372 item. This function is called like a sort function. The items look
373 like (ITEM-NAME . BUFFER).
375 ITEM-NAME is the name of the item that will appear in the menu.
376 BUFFER is the buffer, this is not necessarily the current buffer.
378 Set this to nil or t if you don't want any sorting (faster)."
379 :type '(choice (const msb-sort-by-name)
380 (const :tag "Newest first" t)
381 (const :tag "Oldest first" nil))
382 :set 'msb-custom-set
383 :group 'msb
386 (defcustom msb-files-by-directory nil
387 "*Non-nil means that files should be sorted by directory.
388 This is instead of the groups in `msb-menu-cond'."
389 :type 'boolean
390 :set 'msb-custom-set
391 :group 'msb)
393 (defcustom msb-after-load-hooks nil
394 "Hooks to be run after the msb package has been loaded."
395 :type 'hook
396 :set 'msb-custom-set
397 :group 'msb)
400 ;;; Internal variables
403 ;; The last calculated menu.
404 (defvar msb--last-buffer-menu nil)
406 ;; If this is non-nil, then it is a string that describes the error.
407 (defvar msb--error nil)
410 ;;; Some example function to be used for `msb-item-handling-function'.
412 (defun msb-item-handler (buffer &optional maxbuf)
413 "Create one string item, concerning BUFFER, for the buffer menu.
414 The item looks like:
415 *% <buffer-name>
416 The `*' appears only if the buffer is marked as modified.
417 The `%' appears only if the buffer is read-only.
418 Optional second argument MAXBUF is completely ignored."
419 (let ((name (buffer-name))
420 (modified (if (buffer-modified-p) "*" " "))
421 (read-only (if buffer-read-only "%" " ")))
422 (format "%s%s %s" modified read-only name)))
425 (eval-when-compile (require 'dired))
427 ;; `dired' can be called with a list of the form (directory file1 file2 ...)
428 ;; which causes `dired-directory' to be in the same form.
429 (defun msb--dired-directory ()
430 (cond ((stringp dired-directory)
431 (abbreviate-file-name (expand-file-name dired-directory)))
432 ((consp dired-directory)
433 (abbreviate-file-name (expand-file-name (car dired-directory))))
435 (error "Unknown type of `dired-directory' in buffer %s"
436 (buffer-name)))))
438 (defun msb-dired-item-handler (buffer &optional maxbuf)
439 "Create one string item, concerning a dired BUFFER, for the buffer menu.
440 The item looks like:
441 *% <buffer-name>
442 The `*' appears only if the buffer is marked as modified.
443 The `%' appears only if the buffer is read-only.
444 Optional second argument MAXBUF is completely ignored."
445 (let ((name (msb--dired-directory))
446 (modified (if (buffer-modified-p) "*" " "))
447 (read-only (if buffer-read-only "%" " ")))
448 (format "%s%s %s" modified read-only name)))
450 (defun msb-alon-item-handler (buffer maxbuf)
451 "Create one string item for the buffer menu.
452 The item looks like:
453 <buffer-name> *%# <file-name>
454 The `*' appears only if the buffer is marked as modified.
455 The `%' appears only if the buffer is read-only.
456 The `#' appears only version control file (SCCS/RCS)."
457 (format (format "%%%ds %%s%%s%%s %%s" maxbuf)
458 (buffer-name buffer)
459 (if (buffer-modified-p) "*" " ")
460 (if buffer-read-only "%" " ")
461 (if (and (boundp 'vc-mode) vc-mode) "#" " ")
462 (or buffer-file-name "")))
465 ;;; Some example function to be used for `msb-item-sort-function'.
467 (defun msb-sort-by-name (item1 item2)
468 "Sort the items ITEM1 and ITEM2 by their `buffer-name'.
469 An item looks like (NAME . BUFFER)."
470 (string-lessp (buffer-name (cdr item1))
471 (buffer-name (cdr item2))))
474 (defun msb-sort-by-directory (item1 item2)
475 "Sort the items ITEM1 and ITEM2 by directory name. Made for dired.
476 An item look like (NAME . BUFFER)."
477 (string-lessp (save-excursion (set-buffer (cdr item1))
478 (msb--dired-directory))
479 (save-excursion (set-buffer (cdr item2))
480 (msb--dired-directory))))
483 ;;; msb
485 ;;; This function can be used instead of (mouse-buffer-menu EVENT)
486 ;;; function in "mouse.el".
488 (defun msb (event)
489 "Pop up several menus of buffers for selection with the mouse.
490 This command switches buffers in the window that you clicked on, and
491 selects that window.
493 See the function `mouse-select-buffer' and the variable
494 `msb-menu-cond' for more information about how the menus are split."
495 (interactive "e")
496 (let ((old-window (selected-window))
497 (window (posn-window (event-start event))))
498 (unless (framep window) (select-window window))
499 (let ((buffer (mouse-select-buffer event)))
500 (if buffer
501 (switch-to-buffer buffer)
502 (select-window old-window))))
503 nil)
506 ;;; Some supportive functions
508 (defun msb-invisible-buffer-p (&optional buffer)
509 "Return t if optional BUFFER is an \"invisible\" buffer.
510 If the argument is left out or nil, then the current buffer is considered."
511 (and (> (length (buffer-name buffer)) 0)
512 (eq ?\ (aref (buffer-name buffer) 0))))
514 (defun msb--strip-dir (dir)
515 "Strip one hierarchy level from the end of DIR."
516 (file-name-directory (directory-file-name dir)))
518 ;; Create an alist with all buffers from LIST that lies under the same
519 ;; directory will be in the same item as the directory string.
520 ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K BUFFER-K+1...)) ...)
521 (defun msb--init-file-alist (list)
522 (let ((buffer-alist
523 ;; Make alist that looks like
524 ;; ((PATH-1 BUFFER-1) (PATH-2 BUFFER-2) ...)
525 ;; sorted on PATH-x
526 (sort (mapcan
527 (lambda (buffer)
528 (let ((file-name (expand-file-name (buffer-file-name buffer))))
529 (when file-name
530 (list (cons (msb--strip-dir file-name) buffer)))))
531 list)
532 (lambda (item1 item2)
533 (string< (car item1) (car item2))))))
534 ;; Now clump buffers together that have the same path
535 ;; Make alist that looks like
536 ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K)) ...)
537 (let ((path nil)
538 (buffers nil))
539 (nconc
540 (mapcan (lambda (item)
541 (cond
542 ((and path
543 (string= path (car item)))
544 ;; The same path as earlier: Add to current list of
545 ;; buffers.
546 (push (cdr item) buffers)
547 ;; This item should not be added to list
548 nil)
550 ;; New path
551 (let ((result (and path (cons path buffers))))
552 (setq path (car item))
553 (setq buffers (list (cdr item)))
554 ;; Add the last result the list.
555 (and result (list result))))))
556 buffer-alist)
557 ;; Add the last result to the list
558 (list (cons path buffers))))))
560 (defun msb--format-title (top-found-p path number-of-items)
561 "Format a suitable title for the menu item."
562 (format (if top-found-p "%s... (%d)" "%s (%d)")
563 (abbreviate-file-name path) number-of-items))
565 ;; Variables for debugging.
566 (defvar msb--choose-file-menu-list)
567 (defvar msb--choose-file-menu-arg-list)
569 (defun msb--choose-file-menu (list)
570 "Choose file-menu with respect to directory for every buffer in LIST."
571 (setq msb--choose-file-menu-arg-list list)
572 (let ((buffer-alist (msb--init-file-alist list))
573 (final-list nil)
574 (max-clumped-together (if (numberp msb-max-file-menu-items)
575 msb-max-file-menu-items
576 10))
577 (top-found-p nil)
578 (last-path nil)
579 first rest path buffers old-path)
580 ;; Prepare for looping over all items in buffer-alist
581 (setq first (car buffer-alist)
582 rest (cdr buffer-alist)
583 path (car first)
584 buffers (cdr first))
585 (setq msb--choose-file-menu-list (copy-list rest))
586 ;; This big loop tries to clump buffers together that have a
587 ;; similar name. Remember that buffer-alist is sorted based on the
588 ;; path for the buffers.
589 (while rest
590 (let ((found-p nil)
591 (tmp-rest rest)
592 result
593 new-path item)
594 (setq item (car tmp-rest))
595 ;; Clump together the "rest"-buffers that have a path that is
596 ;; a subpath of the current one.
597 (while (and tmp-rest
598 (<= (length buffers) max-clumped-together)
599 (>= (length (car item)) (length path))
600 (eq t (compare-strings path 0 nil
601 (car item) 0 (length path))))
602 (setq found-p t)
603 (setq buffers (append buffers (cdr item))) ;nconc is faster than append
604 (setq tmp-rest (cdr tmp-rest)
605 item (car tmp-rest)))
606 (cond
607 ((> (length buffers) max-clumped-together)
608 ;; Oh, we failed. Too many buffers clumped together.
609 ;; Just use the original ones for the result.
610 (setq last-path (car first))
611 (push (cons (msb--format-title top-found-p
612 (car first)
613 (length (cdr first)))
614 (cdr first))
615 final-list)
616 (setq top-found-p nil)
617 (setq first (car rest)
618 rest (cdr rest)
619 path (car first)
620 buffers (cdr first)))
622 ;; The first pass of clumping together worked out, go ahead
623 ;; with this result.
624 (when found-p
625 (setq top-found-p t)
626 (setq first (cons path buffers)
627 rest tmp-rest))
628 ;; Now see if we can clump more buffers together if we go up
629 ;; one step in the file hierarchy.
630 ;; If path isn't changed by msb--strip-dir, we are looking
631 ;; at the machine name component of an ange-ftp filename.
632 (setq old-path path)
633 (setq path (msb--strip-dir path)
634 buffers (cdr first))
635 (if (equal old-path path)
636 (setq last-path path))
637 (when (and last-path
638 (or (and (>= (length path) (length last-path))
639 (eq t (compare-strings last-path 0 nil
640 path 0 (length
641 last-path))))
642 (and (< (length path) (length last-path))
643 (eq t (compare-strings path 0 nil
644 last-path 0 (length
645 path))))))
646 ;; We have reached the same place in the file hierarchy as
647 ;; the last result, so we should quit at this point and
648 ;; take what we have as result.
649 (push (cons (msb--format-title top-found-p
650 (car first)
651 (length (cdr first)))
652 (cdr first))
653 final-list)
654 (setq top-found-p nil)
655 (setq first (car rest)
656 rest (cdr rest)
657 path (car first)
658 buffers (cdr first)))))))
659 ;; Now take care of the last item.
660 (when first
661 (push (cons (msb--format-title top-found-p
662 (car first)
663 (length (cdr first)))
664 (cdr first))
665 final-list))
666 (setq top-found-p nil)
667 (nreverse final-list)))
669 (defun msb--create-function-info (menu-cond-elt)
670 "Create a vector from an element MENU-COND-ELT of `msb-menu-cond'.
671 This takes the form:
672 \]BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER)
673 See `msb-menu-cond' for a description of its elements."
674 (let* ((list-symbol (make-symbol "-msb-buffer-list"))
675 (tmp-ih (and (> (length menu-cond-elt) 3)
676 (nth 3 menu-cond-elt)))
677 (item-handler (if (and tmp-ih (fboundp tmp-ih))
678 tmp-ih
679 msb-item-handling-function))
680 (tmp-s (if (> (length menu-cond-elt) 4)
681 (nth 4 menu-cond-elt)
682 msb-item-sort-function))
683 (sorter (if (or (fboundp tmp-s)
684 (null tmp-s)
685 (eq tmp-s t))
686 tmp-s
687 msb-item-sort-function)))
688 (when (< (length menu-cond-elt) 3)
689 (error "Wrong format of msb-menu-cond"))
690 (when (and (> (length menu-cond-elt) 3)
691 (not (fboundp tmp-ih)))
692 (signal 'invalid-function (list tmp-ih)))
693 (when (and (> (length menu-cond-elt) 4)
694 tmp-s
695 (not (fboundp tmp-s))
696 (not (eq tmp-s t)))
697 (signal 'invalid-function (list tmp-s)))
698 (set list-symbol ())
699 (vector list-symbol ;BUFFER-LIST-VARIABLE
700 (nth 0 menu-cond-elt) ;CONDITION
701 (nth 1 menu-cond-elt) ;SORT-KEY
702 (nth 2 menu-cond-elt) ;MENU-TITLE
703 item-handler ;ITEM-HANDLER
704 sorter) ;SORTER
707 ;; This defsubst is only used in `msb--choose-menu' below. It was
708 ;; pulled out merely to make the code somewhat clearer. The indentation
709 ;; level was too big.
710 (defsubst msb--collect (function-info-vector)
711 (let ((result nil)
712 (multi-flag nil)
713 function-info-list)
714 (setq function-info-list
715 (loop for fi
716 across function-info-vector
717 if (and (setq result
718 (eval (aref fi 1))) ;Test CONDITION
719 (not (and (eq result 'no-multi)
720 multi-flag))
721 (progn (when (eq result 'multi)
722 (setq multi-flag t))
724 collect fi
725 until (and result
726 (not (eq result 'multi)))))
727 (when (and (not function-info-list)
728 (not result))
729 (error "No catch-all in msb-menu-cond!"))
730 function-info-list))
732 (defun msb--add-to-menu (buffer function-info max-buffer-name-length)
733 "Add BUFFER to the menu depicted by FUNCTION-INFO.
734 All side-effects. Adds an element of form (BUFFER-TITLE . BUFFER)
735 to the buffer-list variable in function-info."
736 (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
737 ;; Here comes the hairy side-effect!
738 (set list-symbol
739 (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
740 buffer
741 max-buffer-name-length)
742 buffer)
743 (eval list-symbol)))))
745 (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
746 "Select the appropriate menu for BUFFER."
747 ;; This is all side-effects, folks!
748 ;; This should be optimized.
749 (unless (and (not msb-display-invisible-buffers-p)
750 (msb-invisible-buffer-p buffer))
751 (condition-case nil
752 (save-excursion
753 (set-buffer buffer)
754 ;; Menu found. Add to this menu
755 (mapc (lambda (function-info)
756 (msb--add-to-menu buffer function-info max-buffer-name-length))
757 (msb--collect function-info-vector)))
758 (error (unless msb--error
759 (setq msb--error
760 (format
761 "In msb-menu-cond, error for buffer `%s'."
762 (buffer-name buffer)))
763 (error "%s" msb--error))))))
765 (defun msb--create-sort-item (function-info)
766 "Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the buffer-list is empty."
767 (let ((buffer-list (eval (aref function-info 0))))
768 (when buffer-list
769 (let ((sorter (aref function-info 5)) ;SORTER
770 (sort-key (aref function-info 2))) ;MENU-SORT-KEY
771 (when sort-key
772 (cons sort-key
773 (cons (format (aref function-info 3) ;MENU-TITLE
774 (length buffer-list))
775 (cond
776 ((null sorter)
777 buffer-list)
778 ((eq sorter t)
779 (nreverse buffer-list))
781 (sort buffer-list sorter))))))))))
783 (defun msb--aggregate-alist (alist same-predicate sort-predicate)
784 "Return ALIST as a sorted, aggregated alist.
786 In the result all items with the same car element (according to
787 SAME-PREDICATE) are aggregated together. The alist is first sorted by
788 SORT-PREDICATE.
790 Example:
791 (msb--aggregate-alist
792 '((a . a1) (a . a2) (b . b1) (c . c3) (a . a4) (a . a3) (b . b3) (b . b2))
793 (function string=)
794 (lambda (item1 item2)
795 (string< (symbol-name item1) (symbol-name item2))))
796 results in
797 ((a a1 a2 a4 a3) (b b1 b3 b2) (c c3))"
798 (when (not (null alist))
799 (let (result
800 same
801 tmp-old-car
802 tmp-same
803 (first-time-p t)
804 old-car)
805 (nconc
806 (mapcan (lambda (item)
807 (cond
808 (first-time-p
809 (push (cdr item) same)
810 (setq first-time-p nil)
811 (setq old-car (car item))
812 nil)
813 ((funcall same-predicate (car item) old-car)
814 (push (cdr item) same)
815 nil)
817 (setq tmp-same same
818 tmp-old-car old-car)
819 (setq same (list (cdr item))
820 old-car (car item))
821 (list (cons tmp-old-car (nreverse tmp-same))))))
822 (sort alist (lambda (item1 item2)
823 (funcall sort-predicate (car item1) (car item2)))))
824 (list (cons old-car (nreverse same)))))))
827 (defun msb--mode-menu-cond ()
828 (let ((key msb-modes-key))
829 (mapcar (lambda (item)
830 (incf key)
831 (list `( eq major-mode (quote ,(car item)))
833 (concat (cdr item) " (%d)")))
834 (sort
835 (let ((mode-list nil))
836 (mapc (lambda (buffer)
837 (save-excursion
838 (set-buffer buffer)
839 (when (and (not (msb-invisible-buffer-p))
840 (not (assq major-mode mode-list))
841 (push (cons major-mode mode-name)
842 mode-list)))))
843 (cdr (buffer-list)))
844 mode-list)
845 (lambda (item1 item2)
846 (string< (cdr item1) (cdr item2)))))))
848 (defun msb--most-recently-used-menu (max-buffer-name-length)
849 "Return a list for the most recently used buffers.
850 It takes the form ((TITLE . BUFFER-LIST)...)."
851 (when (and (numberp msb-display-most-recently-used)
852 (> msb-display-most-recently-used 0))
853 (let* ((buffers (cdr (buffer-list)))
854 (most-recently-used
855 (loop with n = 0
856 for buffer in buffers
857 if (save-excursion
858 (set-buffer buffer)
859 (and (not (msb-invisible-buffer-p))
860 (not (eq major-mode 'dired-mode))))
861 collect (save-excursion
862 (set-buffer buffer)
863 (cons (funcall msb-item-handling-function
864 buffer
865 max-buffer-name-length)
866 buffer))
867 and do (incf n)
868 until (>= n msb-display-most-recently-used))))
869 (cons (if (stringp msb-most-recently-used-title)
870 (format msb-most-recently-used-title
871 (length most-recently-used))
872 (signal 'wrong-type-argument (list msb-most-recently-used-title)))
873 most-recently-used))))
875 (defun msb--create-buffer-menu-2 ()
876 (let ((max-buffer-name-length 0)
877 file-buffers
878 function-info-vector)
879 ;; Calculate the longest buffer name.
880 (mapc
881 (lambda (buffer)
882 (if (or msb-display-invisible-buffers-p
883 (not (msb-invisible-buffer-p)))
884 (setq max-buffer-name-length
885 (max max-buffer-name-length
886 (length (buffer-name buffer))))))
887 (buffer-list))
888 ;; Make a list with elements of type
889 ;; (BUFFER-LIST-VARIABLE
890 ;; CONDITION
891 ;; MENU-SORT-KEY
892 ;; MENU-TITLE
893 ;; ITEM-HANDLER
894 ;; SORTER)
895 ;; Uses "function-global" variables:
896 ;; function-info-vector
897 (setq function-info-vector
898 (apply (function vector)
899 (mapcar (function msb--create-function-info)
900 (append msb-menu-cond (msb--mode-menu-cond)))))
901 ;; Split the buffer-list into several lists; one list for each
902 ;; criteria. This is the most critical part with respect to time.
903 (mapc (lambda (buffer)
904 (cond ((and msb-files-by-directory
905 (buffer-file-name buffer)
906 ;; exclude ange-ftp buffers
907 ;;(not (string-match "\\/[^/:]+:"
908 ;; (buffer-file-name buffer)))
910 (push buffer file-buffers))
912 (msb--choose-menu buffer
913 function-info-vector
914 max-buffer-name-length))))
915 (buffer-list))
916 (when file-buffers
917 (setq file-buffers
918 (mapcar (lambda (buffer-list)
919 (cons msb-files-by-directory-sort-key
920 (cons (car buffer-list)
921 (sort
922 (mapcar (function
923 (lambda (buffer)
924 (cons (save-excursion
925 (set-buffer buffer)
926 (funcall msb-item-handling-function
927 buffer
928 max-buffer-name-length))
929 buffer)))
930 (cdr buffer-list))
931 (function
932 (lambda (item1 item2)
933 (string< (car item1) (car item2))))))))
934 (msb--choose-file-menu file-buffers))))
935 ;; Now make the menu - a list of (TITLE . BUFFER-LIST)
936 (let* (menu
937 (most-recently-used
938 (msb--most-recently-used-menu max-buffer-name-length))
939 (others (nconc file-buffers
940 (loop for elt
941 across function-info-vector
942 for value = (msb--create-sort-item elt)
943 if value collect value))))
944 (setq menu
945 (mapcar 'cdr ;Remove the SORT-KEY
946 ;; Sort the menus - not the items.
947 (msb--add-separators
948 (sort
949 ;; Get a list of (SORT-KEY TITLE . BUFFER-LIST)
950 ;; Also sorts the items within the menus.
951 (if (cdr most-recently-used)
952 (cons
953 ;; Add most recent used buffers
954 (cons msb-most-recently-used-sort-key
955 most-recently-used)
956 others)
957 others)
958 (lambda (elt1 elt2)
959 (< (car elt1) (car elt2)))))))
960 ;; Now make it a keymap menu
961 (append
962 '(keymap "Select Buffer")
963 (msb--make-keymap-menu menu)
964 (when msb-separator-diff
965 (list (list 'separator "--")))
966 (list (cons 'toggle
967 (cons
968 (if msb-files-by-directory
969 "*Files by type*"
970 "*Files by directory*")
971 'msb--toggle-menu-type)))))))
973 (defun msb--create-buffer-menu ()
974 (save-match-data
975 (save-excursion
976 (msb--create-buffer-menu-2))))
978 (defun msb--toggle-menu-type ()
979 "Multi purpose function for selecting a buffer with the mouse."
980 (interactive)
981 (setq msb-files-by-directory (not msb-files-by-directory))
982 ;; This gets a warning, but it is correct,
983 ;; because this file redefines menu-bar-update-buffers.
984 (msb-menu-bar-update-buffers t))
986 (defun mouse-select-buffer (event)
987 "Pop up several menus of buffers, for selection with the mouse.
988 Returns the selected buffer or nil if no buffer is selected.
990 The way the buffers are split is conveniently handled with the
991 variable `msb-menu-cond'."
992 ;; Popup the menu and return the selected buffer.
993 (when (or msb--error
994 (not msb--last-buffer-menu)
995 (not (fboundp 'frame-or-buffer-changed-p))
996 (frame-or-buffer-changed-p))
997 (setq msb--error nil)
998 (setq msb--last-buffer-menu (msb--create-buffer-menu)))
999 (let ((position event)
1000 choice)
1001 (when (and (fboundp 'posn-x-y)
1002 (fboundp 'posn-window))
1003 (let ((posX (car (posn-x-y (event-start event))))
1004 (posY (cdr (posn-x-y (event-start event))))
1005 (posWind (posn-window (event-start event))))
1006 ;; adjust position
1007 (setq posX (- posX (funcall msb-horizontal-shift-function))
1008 position (list (list posX posY) posWind))))
1009 ;; This `sit-for' magically makes the menu stay up if the mouse
1010 ;; button is released within 0.1 second.
1011 (sit-for 0 100)
1012 ;; Popup the menu
1013 (setq choice (x-popup-menu position msb--last-buffer-menu))
1014 (cond
1015 ((eq (car choice) 'toggle)
1016 ;; Bring up the menu again with type toggled.
1017 (msb--toggle-menu-type)
1018 (mouse-select-buffer event))
1019 ((and (numberp (car choice))
1020 (null (cdr choice)))
1021 (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice) msb--last-buffer-menu))))
1022 (mouse-select-buffer event)))
1023 ((while (numberp (car choice))
1024 (setq choice (cdr choice))))
1025 ((and (stringp (car choice))
1026 (null (cdr choice)))
1027 (car choice))
1028 ((null choice)
1029 choice)
1031 (error "Unknown form for buffer: %s" choice)))))
1033 ;; Add separators
1034 (defun msb--add-separators (sorted-list)
1035 (cond
1036 ((or (not msb-separator-diff)
1037 (not (numberp msb-separator-diff)))
1038 sorted-list)
1040 (let ((last-key nil))
1041 (mapcan
1042 (lambda (item)
1043 (cond
1044 ((and msb-separator-diff
1045 last-key
1046 (> (- (car item) last-key)
1047 msb-separator-diff))
1048 (setq last-key (car item))
1049 (list (cons last-key 'separator)
1050 item))
1052 (setq last-key (car item))
1053 (list item))))
1054 sorted-list)))))
1056 (defun msb--split-menus-2 (list mcount result)
1057 (cond
1058 ((> (length list) msb-max-menu-items)
1059 (let ((count 0)
1060 sub-name
1061 (tmp-list nil))
1062 (while (< count msb-max-menu-items)
1063 (push (pop list) tmp-list)
1064 (incf count))
1065 (setq tmp-list (nreverse tmp-list))
1066 (setq sub-name (concat (car (car tmp-list)) "..."))
1067 (push (nconc (list mcount sub-name
1068 'keymap sub-name)
1069 tmp-list)
1070 result))
1071 (msb--split-menus-2 list (1+ mcount) result))
1072 ((null result)
1073 list)
1075 (let (sub-name)
1076 (setq sub-name (concat (car (car list)) "..."))
1077 (push (nconc (list mcount sub-name
1078 'keymap sub-name)
1079 list)
1080 result))
1081 (nreverse result))))
1083 (defun msb--split-menus (list)
1084 (if (and (integerp msb-max-menu-items)
1085 (> msb-max-menu-items 0))
1086 (msb--split-menus-2 list 0 nil)
1087 list))
1089 (defun msb--make-keymap-menu (raw-menu)
1090 (let ((end (cons '(nil) 'menu-bar-select-buffer))
1091 (mcount 0))
1092 (mapcar
1093 (lambda (sub-menu)
1094 (cond
1095 ((eq 'separator sub-menu)
1096 (list 'separator "--"))
1098 (let ((buffers (mapcar (function
1099 (lambda (item)
1100 (let ((string (car item))
1101 (buffer (cdr item)))
1102 (cons (buffer-name buffer)
1103 (cons string end)))))
1104 (cdr sub-menu))))
1105 (nconc (list (incf mcount) (car sub-menu)
1106 'keymap (car sub-menu))
1107 (msb--split-menus buffers))))))
1108 raw-menu)))
1110 (defun msb-menu-bar-update-buffers (&optional arg)
1111 "A re-written version of `menu-bar-update-buffers'."
1112 ;; If user discards the Buffers item, play along.
1113 (when (and (lookup-key (current-global-map) [menu-bar buffer])
1114 (or (not (fboundp 'frame-or-buffer-changed-p))
1115 (frame-or-buffer-changed-p)
1116 arg))
1117 (let ((frames (frame-list))
1118 buffers-menu frames-menu)
1119 ;; Make the menu of buffers proper.
1120 (setq msb--last-buffer-menu (msb--create-buffer-menu))
1121 (setq buffers-menu msb--last-buffer-menu)
1122 ;; Make a Frames menu if we have more than one frame.
1123 (when (cdr frames)
1124 (let* ((frame-length (length frames))
1125 (f-title (format "Frames (%d)" frame-length)))
1126 ;; List only the N most recently selected frames
1127 (when (and (integerp msb-max-menu-items)
1128 (> msb-max-menu-items 1)
1129 (> frame-length msb-max-menu-items))
1130 (setcdr (nthcdr msb-max-menu-items frames) nil))
1131 (setq frames-menu
1132 (nconc
1133 (list 'frame f-title '(nil) 'keymap f-title)
1134 (mapcar
1135 (lambda (frame)
1136 (nconc
1137 (list frame
1138 (cdr (assq 'name
1139 (frame-parameters frame)))
1140 (cons nil nil))
1141 'menu-bar-select-frame))
1142 frames)))))
1143 (define-key (current-global-map) [menu-bar buffer]
1144 (cons "Buffers"
1145 (if (and buffers-menu frames-menu)
1146 ;; Combine Frame and Buffers menus with separator between
1147 (nconc (list 'keymap "Buffers and Frames" frames-menu
1148 (and msb-separator-diff '(separator "--")))
1149 (cddr buffers-menu))
1150 (or buffers-menu 'undefined)))))))
1152 ;; Snarf current bindings of `mouse-buffer-menu' (normally
1153 ;; C-down-mouse-1).
1154 (defvar msb-mode-map
1155 (let ((map (make-sparse-keymap)))
1156 (mapcar (lambda (key)
1157 (define-key map key #'msb))
1158 (where-is-internal 'mouse-buffer-menu (make-sparse-keymap)))
1159 map))
1161 ;;;###autoload
1162 (defun msb-mode (&optional arg)
1163 "Toggle Msb mode.
1164 With arg, turn Msb mode on if and only if arg is positive.
1165 This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
1166 different buffer menu using the function `msb'."
1167 (interactive "P")
1168 (setq msb-mode (if arg
1169 (> (prefix-numeric-value arg) 0)
1170 (not msb-mode)))
1171 (if msb-mode
1172 (progn
1173 (add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1174 (remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
1175 (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1176 (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
1177 (run-hooks 'menu-bar-update-hook))
1179 (add-to-list 'minor-mode-map-alist (cons 'msb-mode msb-mode-map))
1181 (provide 'msb)
1182 (eval-after-load 'msb (run-hooks 'msb-after-load-hooks))
1184 ;;; msb.el ends here