Add 2008 to copyright years.
[bpt/emacs.git] / lisp / msb.el
1 ;;; msb.el --- customizable buffer-selection with multiple menus
2
3 ;; Copyright (C) 1993, 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002,
4 ;; 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
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
11
12 ;; This file is part of GNU Emacs.
13
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 3, or (at your option)
17 ;; any later version.
18
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.
23
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.
28
29 ;;; Commentary:
30
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.
36 ;;
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)
44 ;;
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'.
48 ;;
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.
52 ;;
53 ;; Also check out the variable `msb-display-invisible-buffers-p'.
54
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.
60
61 ;; Future enhancements:
62
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>
78
79 ;; This version turned into a global minor mode and subsequently
80 ;; hacked on by Dave Love.
81 ;;; Code:
82
83 (eval-when-compile (require 'cl))
84
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)")))
126
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)")))
192
193 ;;;
194 ;;; Customizable variables
195 ;;;
196
197 (defgroup msb nil
198 "Customizable buffer-selection with multiple menus."
199 :prefix "msb-"
200 :group 'mouse)
201
202 (defun msb-custom-set (symbol value)
203 "Set the value of custom variables for msb."
204 (set symbol value)
205 (if (and (featurep 'msb) msb-mode)
206 ;; wait until package has been loaded before bothering to update
207 ;; the buffer lists.
208 (msb-menu-bar-update-buffers t)))
209
210 (defcustom msb-menu-cond msb--very-many-menus
211 "*List of criteria for splitting the mouse buffer menu.
212 The elements in the list should be of this type:
213 (CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLING-FN ITEM-SORT-FN).
214
215 When making the split, the buffers are tested one by one against the
216 CONDITION, just like a Lisp cond: When hitting a true condition, the
217 other criteria are *not* tested and the buffer name will appear in the
218 menu with the menu-title corresponding to the true condition.
219
220 If the condition returns the symbol `multi', then the buffer will be
221 added to this menu *and* tested for other menus too. If it returns
222 `no-multi', then the buffer will only be added if it hasn't been added
223 to any other menu.
224
225 During this test, the buffer in question is the current buffer, and
226 the test is surrounded by calls to `save-excursion' and
227 `save-match-data'.
228
229 The categories are sorted by MENU-SORT-KEY. Smaller keys are on top.
230 A value of nil means don't display this menu.
231
232 MENU-TITLE is really a format. If you add %d in it, the %d is
233 replaced with the number of items in that menu.
234
235 ITEM-HANDLING-FN is optional. If it is supplied and is a function,
236 then it is used for displaying the items in that particular buffer
237 menu, otherwise the function pointed out by
238 `msb-item-handling-function' is used.
239
240 ITEM-SORT-FN is also optional.
241 If it is not supplied, the function pointed out by
242 `msb-item-sort-function' is used.
243 If it is nil, then no sort takes place and the buffers are presented
244 in least-recently-used order.
245 If it is t, then no sort takes place and the buffers are presented in
246 most-recently-used order.
247 If it is supplied and non-nil and not t than it is used for sorting
248 the items in that particular buffer menu.
249
250 Note1: There should always be a `catch-all' as last element, in this
251 list. That is an element like (t TITLE ITEM-HANDLING-FUNCTION).
252 Note2: A buffer menu appears only if it has at least one buffer in it.
253 Note3: If you have a CONDITION that can't be evaluated you will get an
254 error every time you do \\[msb]."
255 :type `(choice (const :tag "long" :value ,msb--very-many-menus)
256 (const :tag "short" :value ,msb--few-menus)
257 (sexp :tag "user"))
258 :set 'msb-custom-set
259 :group 'msb)
260
261 (defcustom msb-modes-key 4000
262 "The sort key for files sorted by mode."
263 :type 'integer
264 :set 'msb-custom-set
265 :group 'msb
266 :version "20.3")
267
268 (defcustom msb-separator-diff 100
269 "*Non-nil means use separators.
270 The separators will appear between all menus that have a sorting key
271 that differs by this value or more."
272 :type '(choice integer (const nil))
273 :set 'msb-custom-set
274 :group 'msb)
275
276 (defvar msb-files-by-directory-sort-key 0
277 "*The sort key for files sorted by directory.")
278
279 (defcustom msb-max-menu-items 15
280 "*The maximum number of items in a menu.
281 If this variable is set to 15 for instance, then the submenu will be
282 split up in minor parts, 15 items each. A value of nil means no limit."
283 :type '(choice integer (const nil))
284 :set 'msb-custom-set
285 :group 'msb)
286
287 (defcustom msb-max-file-menu-items 10
288 "*The maximum number of items from different directories.
289
290 When the menu is of type `file by directory', this is the maximum
291 number of buffers that are clumped together from different
292 directories.
293
294 Set this to 1 if you want one menu per directory instead of clumping
295 them together.
296
297 If the value is not a number, then the value 10 is used."
298 :type 'integer
299 :set 'msb-custom-set
300 :group 'msb)
301
302 (defcustom msb-most-recently-used-sort-key -1010
303 "*Where should the menu with the most recently used buffers be placed?"
304 :type 'integer
305 :set 'msb-custom-set
306 :group 'msb)
307
308 (defcustom msb-display-most-recently-used 15
309 "*How many buffers should be in the most-recently-used menu.
310 No buffers at all if less than 1 or nil (or any non-number)."
311 :type 'integer
312 :set 'msb-custom-set
313 :group 'msb)
314
315 (defcustom msb-most-recently-used-title "Most recently used (%d)"
316 "*The title for the most-recently-used menu."
317 :type 'string
318 :set 'msb-custom-set
319 :group 'msb)
320
321 (defvar msb-horizontal-shift-function '(lambda () 0)
322 "*Function that specifies how many pixels to shift the top menu leftwards.")
323
324 (defcustom msb-display-invisible-buffers-p nil
325 "*Show invisible buffers or not.
326 Non-nil means that the buffer menu should include buffers that have
327 names that starts with a space character."
328 :type 'boolean
329 :set 'msb-custom-set
330 :group 'msb)
331
332 (defvar msb-item-handling-function 'msb-item-handler
333 "*The appearance of a buffer menu.
334
335 The default function to call for handling the appearance of a menu
336 item. It should take two arguments, BUFFER and MAX-BUFFER-NAME-LENGTH,
337 where the latter is the max length of all buffer names.
338
339 The function should return the string to use in the menu.
340
341 When the function is called, BUFFER is the current buffer. This
342 function is called for items in the variable `msb-menu-cond' that have
343 nil as ITEM-HANDLING-FUNCTION. See `msb-menu-cond' for more
344 information.")
345
346 (defcustom msb-item-sort-function 'msb-sort-by-name
347 "*The order of items in a buffer menu.
348
349 The default function to call for handling the order of items in a menu
350 item. This function is called like a sort function. The items look
351 like (ITEM-NAME . BUFFER).
352
353 ITEM-NAME is the name of the item that will appear in the menu.
354 BUFFER is the buffer, this is not necessarily the current buffer.
355
356 Set this to nil or t if you don't want any sorting (faster)."
357 :type '(choice (const msb-sort-by-name)
358 (const :tag "Newest first" t)
359 (const :tag "Oldest first" nil))
360 :set 'msb-custom-set
361 :group 'msb)
362
363 (defcustom msb-files-by-directory nil
364 "*Non-nil means that files should be sorted by directory.
365 This is instead of the groups in `msb-menu-cond'."
366 :type 'boolean
367 :set 'msb-custom-set
368 :group 'msb)
369
370 (defcustom msb-after-load-hook nil
371 "Hook run after the msb package has been loaded."
372 :type 'hook
373 :set 'msb-custom-set
374 :group 'msb)
375
376 ;;;
377 ;;; Internal variables
378 ;;;
379
380 ;; The last calculated menu.
381 (defvar msb--last-buffer-menu nil)
382
383 ;; If this is non-nil, then it is a string that describes the error.
384 (defvar msb--error nil)
385
386 ;;;
387 ;;; Some example function to be used for `msb-item-handling-function'.
388 ;;;
389 (defun msb-item-handler (buffer &optional maxbuf)
390 "Create one string item, concerning BUFFER, for the buffer menu.
391 The item looks like:
392 *% <buffer-name>
393 The `*' appears only if the buffer is marked as modified.
394 The `%' appears only if the buffer is read-only.
395 Optional second argument MAXBUF is completely ignored."
396 (let ((name (buffer-name))
397 (modified (if (buffer-modified-p) "*" " "))
398 (read-only (if buffer-read-only "%" " ")))
399 (format "%s%s %s" modified read-only name)))
400
401
402 (eval-when-compile (require 'dired))
403
404 ;; `dired' can be called with a list of the form (directory file1 file2 ...)
405 ;; which causes `dired-directory' to be in the same form.
406 (defun msb--dired-directory ()
407 (cond ((stringp dired-directory)
408 (abbreviate-file-name (expand-file-name dired-directory)))
409 ((consp dired-directory)
410 (abbreviate-file-name (expand-file-name (car dired-directory))))
411 (t
412 (error "Unknown type of `dired-directory' in buffer %s"
413 (buffer-name)))))
414
415 (defun msb-dired-item-handler (buffer &optional maxbuf)
416 "Create one string item, concerning a dired BUFFER, for the buffer menu.
417 The item looks like:
418 *% <buffer-name>
419 The `*' appears only if the buffer is marked as modified.
420 The `%' appears only if the buffer is read-only.
421 Optional second argument MAXBUF is completely ignored."
422 (let ((name (msb--dired-directory))
423 (modified (if (buffer-modified-p) "*" " "))
424 (read-only (if buffer-read-only "%" " ")))
425 (format "%s%s %s" modified read-only name)))
426
427 (defun msb-alon-item-handler (buffer maxbuf)
428 "Create one string item for the buffer menu.
429 The item looks like:
430 <buffer-name> *%# <file-name>
431 The `*' appears only if the buffer is marked as modified.
432 The `%' appears only if the buffer is read-only.
433 The `#' appears only version control file (SCCS/RCS)."
434 (format (format "%%%ds %%s%%s%%s %%s" maxbuf)
435 (buffer-name buffer)
436 (if (buffer-modified-p) "*" " ")
437 (if buffer-read-only "%" " ")
438 (if (and (boundp 'vc-mode) vc-mode) "#" " ")
439 (or buffer-file-name "")))
440
441 ;;;
442 ;;; Some example function to be used for `msb-item-sort-function'.
443 ;;;
444 (defun msb-sort-by-name (item1 item2)
445 "Sort the items ITEM1 and ITEM2 by their `buffer-name'.
446 An item looks like (NAME . BUFFER)."
447 (string-lessp (buffer-name (cdr item1))
448 (buffer-name (cdr item2))))
449
450
451 (defun msb-sort-by-directory (item1 item2)
452 "Sort the items ITEM1 and ITEM2 by directory name. Made for dired.
453 An item look like (NAME . BUFFER)."
454 (string-lessp (with-current-buffer (cdr item1)
455 (msb--dired-directory))
456 (with-current-buffer (cdr item2)
457 (msb--dired-directory))))
458
459 ;;;
460 ;;; msb
461 ;;;
462 ;;; This function can be used instead of (mouse-buffer-menu EVENT)
463 ;;; function in "mouse.el".
464 ;;;
465 (defun msb (event)
466 "Pop up several menus of buffers for selection with the mouse.
467 This command switches buffers in the window that you clicked on, and
468 selects that window.
469
470 See the function `mouse-select-buffer' and the variable
471 `msb-menu-cond' for more information about how the menus are split."
472 (interactive "e")
473 (let ((old-window (selected-window))
474 (window (posn-window (event-start event)))
475 early-release)
476 (unless (framep window) (select-window window))
477 ;; This `sit-for' magically makes the menu stay up if the mouse
478 ;; button is released within 0.1 second.
479 (setq early-release (not (sit-for 0.1 t)))
480 (let ((buffer (mouse-select-buffer event)))
481 (if buffer
482 (switch-to-buffer buffer)
483 (select-window old-window)))
484 ;; If the above `sit-for' was interrupted by a mouse-up, avoid
485 ;; generating a drag event.
486 (if (and early-release (memq 'down (event-modifiers last-input-event)))
487 (discard-input)))
488 nil)
489
490 ;;;
491 ;;; Some supportive functions
492 ;;;
493 (defun msb-invisible-buffer-p (&optional buffer)
494 "Return t if optional BUFFER is an \"invisible\" buffer.
495 If the argument is left out or nil, then the current buffer is considered."
496 (and (> (length (buffer-name buffer)) 0)
497 (eq ?\s (aref (buffer-name buffer) 0))))
498
499 (defun msb--strip-dir (dir)
500 "Strip one hierarchy level from the end of DIR."
501 (file-name-directory (directory-file-name dir)))
502
503 ;; Create an alist with all buffers from LIST that lies under the same
504 ;; directory will be in the same item as the directory name.
505 ;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K BUFFER-K+1...)) ...)
506 (defun msb--init-file-alist (list)
507 (let ((buffer-alist
508 ;; Make alist that looks like
509 ;; ((DIR-1 BUFFER-1) (DIR-2 BUFFER-2) ...)
510 ;; sorted on DIR-x
511 (sort
512 (apply #'nconc
513 (mapcar
514 (lambda (buffer)
515 (let ((file-name (expand-file-name
516 (buffer-file-name buffer))))
517 (when file-name
518 (list (cons (msb--strip-dir file-name) buffer)))))
519 list))
520 (lambda (item1 item2)
521 (string< (car item1) (car item2))))))
522 ;; Now clump buffers together that have the same directory name
523 ;; Make alist that looks like
524 ;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K)) ...)
525 (let ((dir nil)
526 (buffers nil))
527 (nconc
528 (apply
529 #'nconc
530 (mapcar (lambda (item)
531 (cond
532 ((equal dir (car item))
533 ;; The same dir as earlier:
534 ;; Add to current list of buffers.
535 (push (cdr item) buffers)
536 ;; This item should not be added to list
537 nil)
538 (t
539 ;; New dir
540 (let ((result (and dir (cons dir buffers))))
541 (setq dir (car item))
542 (setq buffers (list (cdr item)))
543 ;; Add the last result the list.
544 (and result (list result))))))
545 buffer-alist))
546 ;; Add the last result to the list
547 (list (cons dir buffers))))))
548
549 (defun msb--format-title (top-found-p dir number-of-items)
550 "Format a suitable title for the menu item."
551 (format (if top-found-p "%s... (%d)" "%s (%d)")
552 (abbreviate-file-name dir) number-of-items))
553
554 ;; Variables for debugging.
555 (defvar msb--choose-file-menu-list)
556 (defvar msb--choose-file-menu-arg-list)
557
558 (defun msb--choose-file-menu (list)
559 "Choose file-menu with respect to directory for every buffer in LIST."
560 (setq msb--choose-file-menu-arg-list list)
561 (let ((buffer-alist (msb--init-file-alist list))
562 (final-list nil)
563 (max-clumped-together (if (numberp msb-max-file-menu-items)
564 msb-max-file-menu-items
565 10))
566 (top-found-p nil)
567 (last-dir nil)
568 first rest dir buffers old-dir)
569 ;; Prepare for looping over all items in buffer-alist
570 (setq first (car buffer-alist)
571 rest (cdr buffer-alist)
572 dir (car first)
573 buffers (cdr first))
574 (setq msb--choose-file-menu-list (copy-sequence rest))
575 ;; This big loop tries to clump buffers together that have a
576 ;; similar name. Remember that buffer-alist is sorted based on the
577 ;; directory name of the buffers' visited files.
578 (while rest
579 (let ((found-p nil)
580 (tmp-rest rest)
581 item)
582 (setq item (car tmp-rest))
583 ;; Clump together the "rest"-buffers that have a dir that is
584 ;; a subdir of the current one.
585 (while (and tmp-rest
586 (<= (length buffers) max-clumped-together)
587 (>= (length (car item)) (length dir))
588 ;; `completion-ignore-case' seems to default to t
589 ;; on the systems with case-insensitive file names.
590 (eq t (compare-strings dir 0 nil
591 (car item) 0 (length dir)
592 completion-ignore-case)))
593 (setq found-p t)
594 (setq buffers (append buffers (cdr item))) ;nconc is faster than append
595 (setq tmp-rest (cdr tmp-rest)
596 item (car tmp-rest)))
597 (cond
598 ((> (length buffers) max-clumped-together)
599 ;; Oh, we failed. Too many buffers clumped together.
600 ;; Just use the original ones for the result.
601 (setq last-dir (car first))
602 (push (cons (msb--format-title top-found-p
603 (car first)
604 (length (cdr first)))
605 (cdr first))
606 final-list)
607 (setq top-found-p nil)
608 (setq first (car rest)
609 rest (cdr rest)
610 dir (car first)
611 buffers (cdr first)))
612 (t
613 ;; The first pass of clumping together worked out, go ahead
614 ;; with this result.
615 (when found-p
616 (setq top-found-p t)
617 (setq first (cons dir buffers)
618 rest tmp-rest))
619 ;; Now see if we can clump more buffers together if we go up
620 ;; one step in the file hierarchy.
621 ;; If dir isn't changed by msb--strip-dir, we are looking
622 ;; at the machine name component of an ange-ftp filename.
623 (setq old-dir dir)
624 (setq dir (msb--strip-dir dir)
625 buffers (cdr first))
626 (if (equal old-dir dir)
627 (setq last-dir dir))
628 (when (and last-dir
629 (or (and (>= (length dir) (length last-dir))
630 (eq t (compare-strings
631 last-dir 0 nil dir 0
632 (length last-dir)
633 completion-ignore-case)))
634 (and (< (length dir) (length last-dir))
635 (eq t (compare-strings
636 dir 0 nil last-dir 0 (length dir)
637 completion-ignore-case)))))
638 ;; We have reached the same place in the file hierarchy as
639 ;; the last result, so we should quit at this point and
640 ;; take what we have as result.
641 (push (cons (msb--format-title top-found-p
642 (car first)
643 (length (cdr first)))
644 (cdr first))
645 final-list)
646 (setq top-found-p nil)
647 (setq first (car rest)
648 rest (cdr rest)
649 dir (car first)
650 buffers (cdr first)))))))
651 ;; Now take care of the last item.
652 (when first
653 (push (cons (msb--format-title top-found-p
654 (car first)
655 (length (cdr first)))
656 (cdr first))
657 final-list))
658 (setq top-found-p nil)
659 (nreverse final-list)))
660
661 (defun msb--create-function-info (menu-cond-elt)
662 "Create a vector from an element MENU-COND-ELT of `msb-menu-cond'.
663 This takes the form:
664 \[BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER]
665 See `msb-menu-cond' for a description of its elements."
666 (let* ((list-symbol (make-symbol "-msb-buffer-list"))
667 (tmp-ih (and (> (length menu-cond-elt) 3)
668 (nth 3 menu-cond-elt)))
669 (item-handler (if (and tmp-ih (fboundp tmp-ih))
670 tmp-ih
671 msb-item-handling-function))
672 (tmp-s (if (> (length menu-cond-elt) 4)
673 (nth 4 menu-cond-elt)
674 msb-item-sort-function))
675 (sorter (if (or (fboundp tmp-s)
676 (null tmp-s)
677 (eq tmp-s t))
678 tmp-s
679 msb-item-sort-function)))
680 (when (< (length menu-cond-elt) 3)
681 (error "Wrong format of msb-menu-cond"))
682 (when (and (> (length menu-cond-elt) 3)
683 (not (fboundp tmp-ih)))
684 (signal 'invalid-function (list tmp-ih)))
685 (when (and (> (length menu-cond-elt) 4)
686 tmp-s
687 (not (fboundp tmp-s))
688 (not (eq tmp-s t)))
689 (signal 'invalid-function (list tmp-s)))
690 (set list-symbol ())
691 (vector list-symbol ;BUFFER-LIST-VARIABLE
692 (nth 0 menu-cond-elt) ;CONDITION
693 (nth 1 menu-cond-elt) ;SORT-KEY
694 (nth 2 menu-cond-elt) ;MENU-TITLE
695 item-handler ;ITEM-HANDLER
696 sorter) ;SORTER
697 ))
698
699 ;; This defsubst is only used in `msb--choose-menu' below. It was
700 ;; pulled out merely to make the code somewhat clearer. The indentation
701 ;; level was too big.
702 (defsubst msb--collect (function-info-vector)
703 (let ((result nil)
704 (multi-flag nil)
705 function-info-list)
706 (setq function-info-list
707 (loop for fi
708 across function-info-vector
709 if (and (setq result
710 (eval (aref fi 1))) ;Test CONDITION
711 (not (and (eq result 'no-multi)
712 multi-flag))
713 (progn (when (eq result 'multi)
714 (setq multi-flag t))
715 t))
716 collect fi
717 until (and result
718 (not (eq result 'multi)))))
719 (when (and (not function-info-list)
720 (not result))
721 (error "No catch-all in msb-menu-cond!"))
722 function-info-list))
723
724 (defun msb--add-to-menu (buffer function-info max-buffer-name-length)
725 "Add BUFFER to the menu depicted by FUNCTION-INFO.
726 All side-effects. Adds an element of form (BUFFER-TITLE . BUFFER)
727 to the buffer-list variable in FUNCTION-INFO."
728 (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
729 ;; Here comes the hairy side-effect!
730 (set list-symbol
731 (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
732 buffer
733 max-buffer-name-length)
734 buffer)
735 (eval list-symbol)))))
736
737 (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
738 "Select the appropriate menu for BUFFER."
739 ;; This is all side-effects, folks!
740 ;; This should be optimized.
741 (unless (and (not msb-display-invisible-buffers-p)
742 (msb-invisible-buffer-p buffer))
743 (condition-case nil
744 (with-current-buffer buffer
745 ;; Menu found. Add to this menu
746 (dolist (info (msb--collect function-info-vector))
747 (msb--add-to-menu buffer info max-buffer-name-length)))
748 (error (unless msb--error
749 (setq msb--error
750 (format
751 "In msb-menu-cond, error for buffer `%s'."
752 (buffer-name buffer)))
753 (error "%s" msb--error))))))
754
755 (defun msb--create-sort-item (function-info)
756 "Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the buffer-list is empty."
757 (let ((buffer-list (eval (aref function-info 0))))
758 (when buffer-list
759 (let ((sorter (aref function-info 5)) ;SORTER
760 (sort-key (aref function-info 2))) ;MENU-SORT-KEY
761 (when sort-key
762 (cons sort-key
763 (cons (format (aref function-info 3) ;MENU-TITLE
764 (length buffer-list))
765 (cond
766 ((null sorter)
767 buffer-list)
768 ((eq sorter t)
769 (nreverse buffer-list))
770 (t
771 (sort buffer-list sorter))))))))))
772
773 (defun msb--aggregate-alist (alist same-predicate sort-predicate)
774 "Return ALIST as a sorted, aggregated alist.
775
776 In the result all items with the same car element (according to
777 SAME-PREDICATE) are aggregated together. The alist is first sorted by
778 SORT-PREDICATE.
779
780 Example:
781 \(msb--aggregate-alist
782 '((a . a1) (a . a2) (b . b1) (c . c3) (a . a4) (a . a3) (b . b3) (b . b2))
783 (function string=)
784 (lambda (item1 item2)
785 (string< (symbol-name item1) (symbol-name item2))))
786 results in
787 \((a a1 a2 a4 a3) (b b1 b3 b2) (c c3))"
788 (when (not (null alist))
789 (let (same
790 tmp-old-car
791 tmp-same
792 (first-time-p t)
793 old-car)
794 (nconc
795 (apply #'nconc
796 (mapcar
797 (lambda (item)
798 (cond
799 (first-time-p
800 (push (cdr item) same)
801 (setq first-time-p nil)
802 (setq old-car (car item))
803 nil)
804 ((funcall same-predicate (car item) old-car)
805 (push (cdr item) same)
806 nil)
807 (t
808 (setq tmp-same same
809 tmp-old-car old-car)
810 (setq same (list (cdr item))
811 old-car (car item))
812 (list (cons tmp-old-car (nreverse tmp-same))))))
813 (sort alist (lambda (item1 item2)
814 (funcall sort-predicate
815 (car item1) (car item2))))))
816 (list (cons old-car (nreverse same)))))))
817
818
819 (defun msb--mode-menu-cond ()
820 (let ((key msb-modes-key))
821 (mapcar (lambda (item)
822 (incf key)
823 (list `( eq major-mode (quote ,(car item)))
824 key
825 (concat (cdr item) " (%d)")))
826 (sort
827 (let ((mode-list nil))
828 (dolist (buffer (cdr (buffer-list)))
829 (with-current-buffer buffer
830 (when (and (not (msb-invisible-buffer-p))
831 (not (assq major-mode mode-list)))
832 (push (cons major-mode mode-name)
833 mode-list))))
834 mode-list)
835 (lambda (item1 item2)
836 (string< (cdr item1) (cdr item2)))))))
837
838 (defun msb--most-recently-used-menu (max-buffer-name-length)
839 "Return a list for the most recently used buffers.
840 It takes the form ((TITLE . BUFFER-LIST)...)."
841 (when (and (numberp msb-display-most-recently-used)
842 (> msb-display-most-recently-used 0))
843 (let* ((buffers (cdr (buffer-list)))
844 (most-recently-used
845 (loop with n = 0
846 for buffer in buffers
847 if (with-current-buffer buffer
848 (and (not (msb-invisible-buffer-p))
849 (not (eq major-mode 'dired-mode))))
850 collect (with-current-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))))
862
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)))
894 )
895 (push buffer file-buffers))
896 (t
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 (list* msb-files-by-directory-sort-key
904 (car buffer-list)
905 (sort
906 (mapcar (lambda (buffer)
907 (cons (with-current-buffer buffer
908 (funcall
909 msb-item-handling-function
910 buffer
911 max-buffer-name-length))
912 buffer))
913 (cdr buffer-list))
914 (lambda (item1 item2)
915 (string< (car item1) (car item2))))))
916 (msb--choose-file-menu file-buffers))))
917 ;; Now make the menu - a list of (TITLE . BUFFER-LIST)
918 (let* (menu
919 (most-recently-used
920 (msb--most-recently-used-menu max-buffer-name-length))
921 (others (nconc file-buffers
922 (loop for elt
923 across function-info-vector
924 for value = (msb--create-sort-item elt)
925 if value collect value))))
926 (setq menu
927 (mapcar 'cdr ;Remove the SORT-KEY
928 ;; Sort the menus - not the items.
929 (msb--add-separators
930 (sort
931 ;; Get a list of (SORT-KEY TITLE . BUFFER-LIST)
932 ;; Also sorts the items within the menus.
933 (if (cdr most-recently-used)
934 (cons
935 ;; Add most recent used buffers
936 (cons msb-most-recently-used-sort-key
937 most-recently-used)
938 others)
939 others)
940 (lambda (elt1 elt2)
941 (< (car elt1) (car elt2)))))))
942 ;; Now make it a keymap menu
943 (append
944 '(keymap "Select Buffer")
945 (msb--make-keymap-menu menu)
946 (when msb-separator-diff
947 (list (list 'separator "--")))
948 (list (cons 'toggle
949 (cons
950 (if msb-files-by-directory
951 "*Files by type*"
952 "*Files by directory*")
953 'msb--toggle-menu-type)))))))
954
955 (defun msb--create-buffer-menu ()
956 (save-match-data
957 (save-excursion
958 (msb--create-buffer-menu-2))))
959
960 (defun msb--toggle-menu-type ()
961 "Multi-purpose function for selecting a buffer with the mouse."
962 (interactive)
963 (setq msb-files-by-directory (not msb-files-by-directory))
964 ;; This gets a warning, but it is correct,
965 ;; because this file redefines menu-bar-update-buffers.
966 (msb-menu-bar-update-buffers t))
967
968 (defun mouse-select-buffer (event)
969 "Pop up several menus of buffers, for selection with the mouse.
970 Returns the selected buffer or nil if no buffer is selected.
971
972 The way the buffers are split is conveniently handled with the
973 variable `msb-menu-cond'."
974 ;; Popup the menu and return the selected buffer.
975 (when (or msb--error
976 (not msb--last-buffer-menu)
977 (not (fboundp 'frame-or-buffer-changed-p))
978 (frame-or-buffer-changed-p))
979 (setq msb--error nil)
980 (setq msb--last-buffer-menu (msb--create-buffer-menu)))
981 (let ((position event)
982 choice)
983 (when (and (fboundp 'posn-x-y)
984 (fboundp 'posn-window))
985 (let ((posX (car (posn-x-y (event-start event))))
986 (posY (cdr (posn-x-y (event-start event))))
987 (posWind (posn-window (event-start event))))
988 ;; adjust position
989 (setq posX (- posX (funcall msb-horizontal-shift-function))
990 position (list (list posX posY) posWind))))
991 ;; Popup the menu
992 (setq choice (x-popup-menu position msb--last-buffer-menu))
993 (cond
994 ((eq (car choice) 'toggle)
995 ;; Bring up the menu again with type toggled.
996 (msb--toggle-menu-type)
997 (mouse-select-buffer event))
998 ((and (numberp (car choice))
999 (null (cdr choice)))
1000 (let ((msb--last-buffer-menu (nthcdr 2 (assq (car choice)
1001 msb--last-buffer-menu))))
1002 (mouse-select-buffer event)))
1003 ((while (numberp (car choice))
1004 (setq choice (cdr choice))))
1005 ((and (stringp (car choice))
1006 (null (cdr choice)))
1007 (car choice))
1008 ((null choice)
1009 choice)
1010 (t
1011 (error "Unknown form for buffer: %s" choice)))))
1012
1013 ;; Add separators
1014 (defun msb--add-separators (sorted-list)
1015 (if (or (not msb-separator-diff)
1016 (not (numberp msb-separator-diff)))
1017 sorted-list
1018 (let ((last-key nil))
1019 (apply #'nconc
1020 (mapcar
1021 (lambda (item)
1022 (cond
1023 ((and msb-separator-diff
1024 last-key
1025 (> (- (car item) last-key)
1026 msb-separator-diff))
1027 (setq last-key (car item))
1028 (list (cons last-key 'separator)
1029 item))
1030 (t
1031 (setq last-key (car item))
1032 (list item))))
1033 sorted-list)))))
1034
1035 (defun msb--split-menus-2 (list mcount result)
1036 (cond
1037 ((> (length list) msb-max-menu-items)
1038 (let ((count 0)
1039 sub-name
1040 (tmp-list nil))
1041 (while (< count msb-max-menu-items)
1042 (push (pop list) tmp-list)
1043 (incf count))
1044 (setq tmp-list (nreverse tmp-list))
1045 (setq sub-name (concat (car (car tmp-list)) "..."))
1046 (push (nconc (list mcount sub-name
1047 'keymap sub-name)
1048 tmp-list)
1049 result))
1050 (msb--split-menus-2 list (1+ mcount) result))
1051 ((null result)
1052 list)
1053 (t
1054 (let (sub-name)
1055 (setq sub-name (concat (car (car list)) "..."))
1056 (push (nconc (list mcount sub-name 'keymap sub-name)
1057 list)
1058 result))
1059 (nreverse result))))
1060
1061 (defun msb--split-menus (list)
1062 (if (and (integerp msb-max-menu-items)
1063 (> msb-max-menu-items 0))
1064 (msb--split-menus-2 list 0 nil)
1065 list))
1066
1067 (defun msb--make-keymap-menu (raw-menu)
1068 (let ((end (cons '(nil) 'menu-bar-select-buffer))
1069 (mcount 0))
1070 (mapcar
1071 (lambda (sub-menu)
1072 (cond
1073 ((eq 'separator sub-menu)
1074 (list 'separator "--"))
1075 (t
1076 (let ((buffers (mapcar (lambda (item)
1077 (cons (buffer-name (cdr item))
1078 (cons (car item) end)))
1079 (cdr sub-menu))))
1080 (nconc (list (incf mcount) (car sub-menu)
1081 'keymap (car sub-menu))
1082 (msb--split-menus buffers))))))
1083 raw-menu)))
1084
1085 (defun msb-menu-bar-update-buffers (&optional arg)
1086 "A re-written version of `menu-bar-update-buffers'."
1087 ;; If user discards the Buffers item, play along.
1088 (when (and (lookup-key (current-global-map) [menu-bar buffer])
1089 (or (not (fboundp 'frame-or-buffer-changed-p))
1090 (frame-or-buffer-changed-p)
1091 arg))
1092 (let ((frames (frame-list))
1093 buffers-menu frames-menu)
1094 ;; Make the menu of buffers proper.
1095 (setq msb--last-buffer-menu (msb--create-buffer-menu))
1096 ;; Skip the `keymap' symbol.
1097 (setq buffers-menu (cdr msb--last-buffer-menu))
1098 ;; Make a Frames menu if we have more than one frame.
1099 (when (cdr frames)
1100 (let* ((frame-length (length frames))
1101 (f-title (format "Frames (%d)" frame-length)))
1102 ;; List only the N most recently selected frames
1103 (when (and (integerp msb-max-menu-items)
1104 (> msb-max-menu-items 1)
1105 (> frame-length msb-max-menu-items))
1106 (setcdr (nthcdr msb-max-menu-items frames) nil))
1107 (setq frames-menu
1108 (nconc
1109 (list 'frame f-title '(nil) 'keymap f-title)
1110 (mapcar
1111 (lambda (frame)
1112 (nconc
1113 (list (frame-parameter frame 'name)
1114 (frame-parameter frame 'name)
1115 (cons nil nil))
1116 'menu-bar-select-frame))
1117 frames)))))
1118 (setcdr global-buffers-menu-map
1119 (if (and buffers-menu frames-menu)
1120 ;; Combine Frame and Buffers menus with separator between
1121 (nconc (list "Buffers and Frames" frames-menu
1122 (and msb-separator-diff '(separator "--")))
1123 (cdr buffers-menu))
1124 buffers-menu)))))
1125
1126 ;; Snarf current bindings of `mouse-buffer-menu' (normally
1127 ;; C-down-mouse-1).
1128 (defvar msb-mode-map
1129 (let ((map (make-sparse-keymap "Msb")))
1130 (define-key map [remap mouse-buffer-menu] 'msb)
1131 map))
1132
1133 ;;;###autoload
1134 (define-minor-mode msb-mode
1135 "Toggle Msb mode.
1136 With arg, turn Msb mode on if and only if arg is positive.
1137 This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
1138 different buffer menu using the function `msb'."
1139 :global t :group 'msb
1140 (if msb-mode
1141 (progn
1142 (add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1143 (remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
1144 (msb-menu-bar-update-buffers t))
1145 (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1146 (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
1147 (menu-bar-update-buffers t)))
1148
1149 (defun msb-unload-hook ()
1150 (msb-mode 0))
1151 (add-hook 'msb-unload-hook 'msb-unload-hook)
1152
1153 (provide 'msb)
1154 (eval-after-load "msb" '(run-hooks 'msb-after-load-hook 'msb-after-load-hooks))
1155
1156 ;; arch-tag: 403f9e82-b92e-4e7a-a797-5d6d9b76da36
1157 ;;; msb.el ends here