*** empty log message ***
[emacs.git] / lisp / msb.el
blob55dd40a91bad26829240d5284e6ef630e0c99e5e
1 ;;; msb.el --- customizable buffer-selection with multiple menus
3 ;; Copyright (C) 1993, 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002,
4 ;; 2003, 2004, 2005, 2006, 2007 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., 51 Franklin Street, Fifth Floor,
27 ;; Boston, MA 02110-1301, 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 early-release)
479 (unless (framep window) (select-window window))
480 ;; This `sit-for' magically makes the menu stay up if the mouse
481 ;; button is released within 0.1 second.
482 (setq early-release (not (sit-for 0.1 t)))
483 (let ((buffer (mouse-select-buffer event)))
484 (if buffer
485 (switch-to-buffer buffer)
486 (select-window old-window)))
487 ;; If the above `sit-for' was interrupted by a mouse-up, avoid
488 ;; generating a drag event.
489 (if (and early-release (memq 'down (event-modifiers last-input-event)))
490 (discard-input)))
491 nil)
494 ;;; Some supportive functions
496 (defun msb-invisible-buffer-p (&optional buffer)
497 "Return t if optional BUFFER is an \"invisible\" buffer.
498 If the argument is left out or nil, then the current buffer is considered."
499 (and (> (length (buffer-name buffer)) 0)
500 (eq ?\s (aref (buffer-name buffer) 0))))
502 (defun msb--strip-dir (dir)
503 "Strip one hierarchy level from the end of DIR."
504 (file-name-directory (directory-file-name dir)))
506 ;; Create an alist with all buffers from LIST that lies under the same
507 ;; directory will be in the same item as the directory name.
508 ;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K BUFFER-K+1...)) ...)
509 (defun msb--init-file-alist (list)
510 (let ((buffer-alist
511 ;; Make alist that looks like
512 ;; ((DIR-1 BUFFER-1) (DIR-2 BUFFER-2) ...)
513 ;; sorted on DIR-x
514 (sort
515 (apply #'nconc
516 (mapcar
517 (lambda (buffer)
518 (let ((file-name (expand-file-name
519 (buffer-file-name buffer))))
520 (when file-name
521 (list (cons (msb--strip-dir file-name) buffer)))))
522 list))
523 (lambda (item1 item2)
524 (string< (car item1) (car item2))))))
525 ;; Now clump buffers together that have the same directory name
526 ;; Make alist that looks like
527 ;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K)) ...)
528 (let ((dir nil)
529 (buffers nil))
530 (nconc
531 (apply
532 #'nconc
533 (mapcar (lambda (item)
534 (cond
535 ((equal dir (car item))
536 ;; The same dir as earlier:
537 ;; Add to current list of buffers.
538 (push (cdr item) buffers)
539 ;; This item should not be added to list
540 nil)
542 ;; New dir
543 (let ((result (and dir (cons dir buffers))))
544 (setq dir (car item))
545 (setq buffers (list (cdr item)))
546 ;; Add the last result the list.
547 (and result (list result))))))
548 buffer-alist))
549 ;; Add the last result to the list
550 (list (cons dir buffers))))))
552 (defun msb--format-title (top-found-p dir number-of-items)
553 "Format a suitable title for the menu item."
554 (format (if top-found-p "%s... (%d)" "%s (%d)")
555 (abbreviate-file-name dir) number-of-items))
557 ;; Variables for debugging.
558 (defvar msb--choose-file-menu-list)
559 (defvar msb--choose-file-menu-arg-list)
561 (defun msb--choose-file-menu (list)
562 "Choose file-menu with respect to directory for every buffer in LIST."
563 (setq msb--choose-file-menu-arg-list list)
564 (let ((buffer-alist (msb--init-file-alist list))
565 (final-list nil)
566 (max-clumped-together (if (numberp msb-max-file-menu-items)
567 msb-max-file-menu-items
568 10))
569 (top-found-p nil)
570 (last-dir nil)
571 first rest dir buffers old-dir)
572 ;; Prepare for looping over all items in buffer-alist
573 (setq first (car buffer-alist)
574 rest (cdr buffer-alist)
575 dir (car first)
576 buffers (cdr first))
577 (setq msb--choose-file-menu-list (copy-sequence rest))
578 ;; This big loop tries to clump buffers together that have a
579 ;; similar name. Remember that buffer-alist is sorted based on the
580 ;; directory name of the buffers' visited files.
581 (while rest
582 (let ((found-p nil)
583 (tmp-rest rest)
584 result
585 new-dir item)
586 (setq item (car tmp-rest))
587 ;; Clump together the "rest"-buffers that have a dir that is
588 ;; a subdir of the current one.
589 (while (and tmp-rest
590 (<= (length buffers) max-clumped-together)
591 (>= (length (car item)) (length dir))
592 ;; `completion-ignore-case' seems to default to t
593 ;; on the systems with case-insensitive file names.
594 (eq t (compare-strings dir 0 nil
595 (car item) 0 (length dir)
596 completion-ignore-case)))
597 (setq found-p t)
598 (setq buffers (append buffers (cdr item))) ;nconc is faster than append
599 (setq tmp-rest (cdr tmp-rest)
600 item (car tmp-rest)))
601 (cond
602 ((> (length buffers) max-clumped-together)
603 ;; Oh, we failed. Too many buffers clumped together.
604 ;; Just use the original ones for the result.
605 (setq last-dir (car first))
606 (push (cons (msb--format-title top-found-p
607 (car first)
608 (length (cdr first)))
609 (cdr first))
610 final-list)
611 (setq top-found-p nil)
612 (setq first (car rest)
613 rest (cdr rest)
614 dir (car first)
615 buffers (cdr first)))
617 ;; The first pass of clumping together worked out, go ahead
618 ;; with this result.
619 (when found-p
620 (setq top-found-p t)
621 (setq first (cons dir buffers)
622 rest tmp-rest))
623 ;; Now see if we can clump more buffers together if we go up
624 ;; one step in the file hierarchy.
625 ;; If dir isn't changed by msb--strip-dir, we are looking
626 ;; at the machine name component of an ange-ftp filename.
627 (setq old-dir dir)
628 (setq dir (msb--strip-dir dir)
629 buffers (cdr first))
630 (if (equal old-dir dir)
631 (setq last-dir dir))
632 (when (and last-dir
633 (or (and (>= (length dir) (length last-dir))
634 (eq t (compare-strings
635 last-dir 0 nil dir 0
636 (length last-dir)
637 completion-ignore-case)))
638 (and (< (length dir) (length last-dir))
639 (eq t (compare-strings
640 dir 0 nil last-dir 0 (length dir)
641 completion-ignore-case)))))
642 ;; We have reached the same place in the file hierarchy as
643 ;; the last result, so we should quit at this point and
644 ;; take what we have as result.
645 (push (cons (msb--format-title top-found-p
646 (car first)
647 (length (cdr first)))
648 (cdr first))
649 final-list)
650 (setq top-found-p nil)
651 (setq first (car rest)
652 rest (cdr rest)
653 dir (car first)
654 buffers (cdr first)))))))
655 ;; Now take care of the last item.
656 (when first
657 (push (cons (msb--format-title top-found-p
658 (car first)
659 (length (cdr first)))
660 (cdr first))
661 final-list))
662 (setq top-found-p nil)
663 (nreverse final-list)))
665 (defun msb--create-function-info (menu-cond-elt)
666 "Create a vector from an element MENU-COND-ELT of `msb-menu-cond'.
667 This takes the form:
668 \]BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER)
669 See `msb-menu-cond' for a description of its elements."
670 (let* ((list-symbol (make-symbol "-msb-buffer-list"))
671 (tmp-ih (and (> (length menu-cond-elt) 3)
672 (nth 3 menu-cond-elt)))
673 (item-handler (if (and tmp-ih (fboundp tmp-ih))
674 tmp-ih
675 msb-item-handling-function))
676 (tmp-s (if (> (length menu-cond-elt) 4)
677 (nth 4 menu-cond-elt)
678 msb-item-sort-function))
679 (sorter (if (or (fboundp tmp-s)
680 (null tmp-s)
681 (eq tmp-s t))
682 tmp-s
683 msb-item-sort-function)))
684 (when (< (length menu-cond-elt) 3)
685 (error "Wrong format of msb-menu-cond"))
686 (when (and (> (length menu-cond-elt) 3)
687 (not (fboundp tmp-ih)))
688 (signal 'invalid-function (list tmp-ih)))
689 (when (and (> (length menu-cond-elt) 4)
690 tmp-s
691 (not (fboundp tmp-s))
692 (not (eq tmp-s t)))
693 (signal 'invalid-function (list tmp-s)))
694 (set list-symbol ())
695 (vector list-symbol ;BUFFER-LIST-VARIABLE
696 (nth 0 menu-cond-elt) ;CONDITION
697 (nth 1 menu-cond-elt) ;SORT-KEY
698 (nth 2 menu-cond-elt) ;MENU-TITLE
699 item-handler ;ITEM-HANDLER
700 sorter) ;SORTER
703 ;; This defsubst is only used in `msb--choose-menu' below. It was
704 ;; pulled out merely to make the code somewhat clearer. The indentation
705 ;; level was too big.
706 (defsubst msb--collect (function-info-vector)
707 (let ((result nil)
708 (multi-flag nil)
709 function-info-list)
710 (setq function-info-list
711 (loop for fi
712 across function-info-vector
713 if (and (setq result
714 (eval (aref fi 1))) ;Test CONDITION
715 (not (and (eq result 'no-multi)
716 multi-flag))
717 (progn (when (eq result 'multi)
718 (setq multi-flag t))
720 collect fi
721 until (and result
722 (not (eq result 'multi)))))
723 (when (and (not function-info-list)
724 (not result))
725 (error "No catch-all in msb-menu-cond!"))
726 function-info-list))
728 (defun msb--add-to-menu (buffer function-info max-buffer-name-length)
729 "Add BUFFER to the menu depicted by FUNCTION-INFO.
730 All side-effects. Adds an element of form (BUFFER-TITLE . BUFFER)
731 to the buffer-list variable in function-info."
732 (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
733 ;; Here comes the hairy side-effect!
734 (set list-symbol
735 (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
736 buffer
737 max-buffer-name-length)
738 buffer)
739 (eval list-symbol)))))
741 (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
742 "Select the appropriate menu for BUFFER."
743 ;; This is all side-effects, folks!
744 ;; This should be optimized.
745 (unless (and (not msb-display-invisible-buffers-p)
746 (msb-invisible-buffer-p buffer))
747 (condition-case nil
748 (save-excursion
749 (set-buffer buffer)
750 ;; Menu found. Add to this menu
751 (dolist (info (msb--collect function-info-vector))
752 (msb--add-to-menu buffer info max-buffer-name-length)))
753 (error (unless msb--error
754 (setq msb--error
755 (format
756 "In msb-menu-cond, error for buffer `%s'."
757 (buffer-name buffer)))
758 (error "%s" msb--error))))))
760 (defun msb--create-sort-item (function-info)
761 "Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the buffer-list is empty."
762 (let ((buffer-list (eval (aref function-info 0))))
763 (when buffer-list
764 (let ((sorter (aref function-info 5)) ;SORTER
765 (sort-key (aref function-info 2))) ;MENU-SORT-KEY
766 (when sort-key
767 (cons sort-key
768 (cons (format (aref function-info 3) ;MENU-TITLE
769 (length buffer-list))
770 (cond
771 ((null sorter)
772 buffer-list)
773 ((eq sorter t)
774 (nreverse buffer-list))
776 (sort buffer-list sorter))))))))))
778 (defun msb--aggregate-alist (alist same-predicate sort-predicate)
779 "Return ALIST as a sorted, aggregated alist.
781 In the result all items with the same car element (according to
782 SAME-PREDICATE) are aggregated together. The alist is first sorted by
783 SORT-PREDICATE.
785 Example:
786 \(msb--aggregate-alist
787 '((a . a1) (a . a2) (b . b1) (c . c3) (a . a4) (a . a3) (b . b3) (b . b2))
788 (function string=)
789 (lambda (item1 item2)
790 (string< (symbol-name item1) (symbol-name item2))))
791 results in
792 \((a a1 a2 a4 a3) (b b1 b3 b2) (c c3))"
793 (when (not (null alist))
794 (let (result
795 same
796 tmp-old-car
797 tmp-same
798 (first-time-p t)
799 old-car)
800 (nconc
801 (apply #'nconc
802 (mapcar
803 (lambda (item)
804 (cond
805 (first-time-p
806 (push (cdr item) same)
807 (setq first-time-p nil)
808 (setq old-car (car item))
809 nil)
810 ((funcall same-predicate (car item) old-car)
811 (push (cdr item) same)
812 nil)
814 (setq tmp-same same
815 tmp-old-car old-car)
816 (setq same (list (cdr item))
817 old-car (car item))
818 (list (cons tmp-old-car (nreverse tmp-same))))))
819 (sort alist (lambda (item1 item2)
820 (funcall sort-predicate (car item1) (car item2))))))
821 (list (cons old-car (nreverse same)))))))
824 (defun msb--mode-menu-cond ()
825 (let ((key msb-modes-key))
826 (mapcar (lambda (item)
827 (incf key)
828 (list `( eq major-mode (quote ,(car item)))
830 (concat (cdr item) " (%d)")))
831 (sort
832 (let ((mode-list nil))
833 (dolist (buffer (cdr (buffer-list)))
834 (save-excursion
835 (set-buffer buffer)
836 (when (and (not (msb-invisible-buffer-p))
837 (not (assq major-mode mode-list)))
838 (push (cons major-mode mode-name)
839 mode-list))))
840 mode-list)
841 (lambda (item1 item2)
842 (string< (cdr item1) (cdr item2)))))))
844 (defun msb--most-recently-used-menu (max-buffer-name-length)
845 "Return a list for the most recently used buffers.
846 It takes the form ((TITLE . BUFFER-LIST)...)."
847 (when (and (numberp msb-display-most-recently-used)
848 (> msb-display-most-recently-used 0))
849 (let* ((buffers (cdr (buffer-list)))
850 (most-recently-used
851 (loop with n = 0
852 for buffer in buffers
853 if (save-excursion
854 (set-buffer buffer)
855 (and (not (msb-invisible-buffer-p))
856 (not (eq major-mode 'dired-mode))))
857 collect (save-excursion
858 (set-buffer buffer)
859 (cons (funcall msb-item-handling-function
860 buffer
861 max-buffer-name-length)
862 buffer))
863 and do (incf n)
864 until (>= n msb-display-most-recently-used))))
865 (cons (if (stringp msb-most-recently-used-title)
866 (format msb-most-recently-used-title
867 (length most-recently-used))
868 (signal 'wrong-type-argument (list msb-most-recently-used-title)))
869 most-recently-used))))
871 (defun msb--create-buffer-menu-2 ()
872 (let ((max-buffer-name-length 0)
873 file-buffers
874 function-info-vector)
875 ;; Calculate the longest buffer name.
876 (dolist (buffer (buffer-list))
877 (when (or msb-display-invisible-buffers-p
878 (not (msb-invisible-buffer-p)))
879 (setq max-buffer-name-length
880 (max max-buffer-name-length (length (buffer-name buffer))))))
881 ;; Make a list with elements of type
882 ;; (BUFFER-LIST-VARIABLE
883 ;; CONDITION
884 ;; MENU-SORT-KEY
885 ;; MENU-TITLE
886 ;; ITEM-HANDLER
887 ;; SORTER)
888 ;; Uses "function-global" variables:
889 ;; function-info-vector
890 (setq function-info-vector
891 (apply (function vector)
892 (mapcar (function msb--create-function-info)
893 (append msb-menu-cond (msb--mode-menu-cond)))))
894 ;; Split the buffer-list into several lists; one list for each
895 ;; criteria. This is the most critical part with respect to time.
896 (dolist (buffer (buffer-list))
897 (cond ((and msb-files-by-directory
898 (buffer-file-name buffer)
899 ;; exclude ange-ftp buffers
900 ;;(not (string-match "\\/[^/:]+:"
901 ;; (buffer-file-name buffer)))
903 (push buffer file-buffers))
905 (msb--choose-menu buffer
906 function-info-vector
907 max-buffer-name-length))))
908 (when file-buffers
909 (setq file-buffers
910 (mapcar (lambda (buffer-list)
911 (cons msb-files-by-directory-sort-key
912 (cons (car buffer-list)
913 (sort
914 (mapcar (function
915 (lambda (buffer)
916 (cons (save-excursion
917 (set-buffer buffer)
918 (funcall msb-item-handling-function
919 buffer
920 max-buffer-name-length))
921 buffer)))
922 (cdr buffer-list))
923 (function
924 (lambda (item1 item2)
925 (string< (car item1) (car item2))))))))
926 (msb--choose-file-menu file-buffers))))
927 ;; Now make the menu - a list of (TITLE . BUFFER-LIST)
928 (let* (menu
929 (most-recently-used
930 (msb--most-recently-used-menu max-buffer-name-length))
931 (others (nconc file-buffers
932 (loop for elt
933 across function-info-vector
934 for value = (msb--create-sort-item elt)
935 if value collect value))))
936 (setq menu
937 (mapcar 'cdr ;Remove the SORT-KEY
938 ;; Sort the menus - not the items.
939 (msb--add-separators
940 (sort
941 ;; Get a list of (SORT-KEY TITLE . BUFFER-LIST)
942 ;; Also sorts the items within the menus.
943 (if (cdr most-recently-used)
944 (cons
945 ;; Add most recent used buffers
946 (cons msb-most-recently-used-sort-key
947 most-recently-used)
948 others)
949 others)
950 (lambda (elt1 elt2)
951 (< (car elt1) (car elt2)))))))
952 ;; Now make it a keymap menu
953 (append
954 '(keymap "Select Buffer")
955 (msb--make-keymap-menu menu)
956 (when msb-separator-diff
957 (list (list 'separator "--")))
958 (list (cons 'toggle
959 (cons
960 (if msb-files-by-directory
961 "*Files by type*"
962 "*Files by directory*")
963 'msb--toggle-menu-type)))))))
965 (defun msb--create-buffer-menu ()
966 (save-match-data
967 (save-excursion
968 (msb--create-buffer-menu-2))))
970 (defun msb--toggle-menu-type ()
971 "Multi purpose function for selecting a buffer with the mouse."
972 (interactive)
973 (setq msb-files-by-directory (not msb-files-by-directory))
974 ;; This gets a warning, but it is correct,
975 ;; because this file redefines menu-bar-update-buffers.
976 (msb-menu-bar-update-buffers t))
978 (defun mouse-select-buffer (event)
979 "Pop up several menus of buffers, for selection with the mouse.
980 Returns the selected buffer or nil if no buffer is selected.
982 The way the buffers are split is conveniently handled with the
983 variable `msb-menu-cond'."
984 ;; Popup the menu and return the selected buffer.
985 (when (or msb--error
986 (not msb--last-buffer-menu)
987 (not (fboundp 'frame-or-buffer-changed-p))
988 (frame-or-buffer-changed-p))
989 (setq msb--error nil)
990 (setq msb--last-buffer-menu (msb--create-buffer-menu)))
991 (let ((position event)
992 choice)
993 (when (and (fboundp 'posn-x-y)
994 (fboundp 'posn-window))
995 (let ((posX (car (posn-x-y (event-start event))))
996 (posY (cdr (posn-x-y (event-start event))))
997 (posWind (posn-window (event-start event))))
998 ;; adjust position
999 (setq posX (- posX (funcall msb-horizontal-shift-function))
1000 position (list (list posX posY) posWind))))
1001 ;; Popup the menu
1002 (setq choice (x-popup-menu position msb--last-buffer-menu))
1003 (cond
1004 ((eq (car choice) 'toggle)
1005 ;; Bring up the menu again with type toggled.
1006 (msb--toggle-menu-type)
1007 (mouse-select-buffer event))
1008 ((and (numberp (car choice))
1009 (null (cdr choice)))
1010 (let ((msb--last-buffer-menu (nthcdr 2 (assq (car choice)
1011 msb--last-buffer-menu))))
1012 (mouse-select-buffer event)))
1013 ((while (numberp (car choice))
1014 (setq choice (cdr choice))))
1015 ((and (stringp (car choice))
1016 (null (cdr choice)))
1017 (car choice))
1018 ((null choice)
1019 choice)
1021 (error "Unknown form for buffer: %s" choice)))))
1023 ;; Add separators
1024 (defun msb--add-separators (sorted-list)
1025 (if (or (not msb-separator-diff)
1026 (not (numberp msb-separator-diff)))
1027 sorted-list
1028 (let ((last-key nil))
1029 (apply #'nconc
1030 (mapcar
1031 (lambda (item)
1032 (cond
1033 ((and msb-separator-diff
1034 last-key
1035 (> (- (car item) last-key)
1036 msb-separator-diff))
1037 (setq last-key (car item))
1038 (list (cons last-key 'separator)
1039 item))
1041 (setq last-key (car item))
1042 (list item))))
1043 sorted-list)))))
1045 (defun msb--split-menus-2 (list mcount result)
1046 (cond
1047 ((> (length list) msb-max-menu-items)
1048 (let ((count 0)
1049 sub-name
1050 (tmp-list nil))
1051 (while (< count msb-max-menu-items)
1052 (push (pop list) tmp-list)
1053 (incf count))
1054 (setq tmp-list (nreverse tmp-list))
1055 (setq sub-name (concat (car (car tmp-list)) "..."))
1056 (push (nconc (list mcount sub-name
1057 'keymap sub-name)
1058 tmp-list)
1059 result))
1060 (msb--split-menus-2 list (1+ mcount) result))
1061 ((null result)
1062 list)
1064 (let (sub-name)
1065 (setq sub-name (concat (car (car list)) "..."))
1066 (push (nconc (list mcount sub-name 'keymap sub-name)
1067 list)
1068 result))
1069 (nreverse result))))
1071 (defun msb--split-menus (list)
1072 (if (and (integerp msb-max-menu-items)
1073 (> msb-max-menu-items 0))
1074 (msb--split-menus-2 list 0 nil)
1075 list))
1077 (defun msb--make-keymap-menu (raw-menu)
1078 (let ((end (cons '(nil) 'menu-bar-select-buffer))
1079 (mcount 0))
1080 (mapcar
1081 (lambda (sub-menu)
1082 (cond
1083 ((eq 'separator sub-menu)
1084 (list 'separator "--"))
1086 (let ((buffers (mapcar (lambda (item)
1087 (cons (buffer-name (cdr item))
1088 (cons (car item) end)))
1089 (cdr sub-menu))))
1090 (nconc (list (incf mcount) (car sub-menu)
1091 'keymap (car sub-menu))
1092 (msb--split-menus buffers))))))
1093 raw-menu)))
1095 (defun msb-menu-bar-update-buffers (&optional arg)
1096 "A re-written version of `menu-bar-update-buffers'."
1097 ;; If user discards the Buffers item, play along.
1098 (when (and (lookup-key (current-global-map) [menu-bar buffer])
1099 (or (not (fboundp 'frame-or-buffer-changed-p))
1100 (frame-or-buffer-changed-p)
1101 arg))
1102 (let ((frames (frame-list))
1103 buffers-menu frames-menu)
1104 ;; Make the menu of buffers proper.
1105 (setq msb--last-buffer-menu (msb--create-buffer-menu))
1106 (setq buffers-menu msb--last-buffer-menu)
1107 ;; Make a Frames menu if we have more than one frame.
1108 (when (cdr frames)
1109 (let* ((frame-length (length frames))
1110 (f-title (format "Frames (%d)" frame-length)))
1111 ;; List only the N most recently selected frames
1112 (when (and (integerp msb-max-menu-items)
1113 (> msb-max-menu-items 1)
1114 (> frame-length msb-max-menu-items))
1115 (setcdr (nthcdr msb-max-menu-items frames) nil))
1116 (setq frames-menu
1117 (nconc
1118 (list 'frame f-title '(nil) 'keymap f-title)
1119 (mapcar
1120 (lambda (frame)
1121 (nconc
1122 (list (frame-parameter frame 'name)
1123 (frame-parameter frame 'name)
1124 (cons nil nil))
1125 'menu-bar-select-frame))
1126 frames)))))
1127 (define-key (current-global-map) [menu-bar buffer]
1128 (cons "Buffers"
1129 (if (and buffers-menu frames-menu)
1130 ;; Combine Frame and Buffers menus with separator between
1131 (nconc (list 'keymap "Buffers and Frames" frames-menu
1132 (and msb-separator-diff '(separator "--")))
1133 (cddr buffers-menu))
1134 (or buffers-menu 'undefined)))))))
1136 ;; Snarf current bindings of `mouse-buffer-menu' (normally
1137 ;; C-down-mouse-1).
1138 (defvar msb-mode-map
1139 (let ((map (make-sparse-keymap "Msb")))
1140 (define-key map [remap mouse-buffer-menu] 'msb)
1141 map))
1143 ;;;###autoload
1144 (define-minor-mode msb-mode
1145 "Toggle Msb mode.
1146 With arg, turn Msb mode on if and only if arg is positive.
1147 This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
1148 different buffer menu using the function `msb'."
1149 :global t :group 'msb
1150 (if msb-mode
1151 (progn
1152 (add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1153 (remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
1154 (msb-menu-bar-update-buffers t))
1155 (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1156 (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
1157 (menu-bar-update-buffers t)))
1159 (defun msb-unload-hook ()
1160 (msb-mode 0))
1161 (add-hook 'msb-unload-hook 'msb-unload-hook)
1163 (provide 'msb)
1164 (eval-after-load "msb" '(run-hooks 'msb-after-load-hook 'msb-after-load-hooks))
1166 ;;; arch-tag: 403f9e82-b92e-4e7a-a797-5d6d9b76da36
1167 ;;; msb.el ends here