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