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