comparison lisp/msb.el @ 10228:4181e3182312

Initial revision
author Richard M. Stallman <rms@gnu.org>
date Fri, 23 Dec 1994 17:58:46 +0000
parents
children 52a1e5ef144c
comparison
equal deleted inserted replaced
10227:31d062ac1d2f 10228:4181e3182312
1 ;;; msb.el --- Customizable buffer-selection with multiple menus.
2 ;; Copyright (C) 1993, 1994 Lars Lindberg <Lars.Lindberg@sypro.cap.se>
3 ;;
4 ;; Author: Lars Lindberg <Lars.Lindberg@sypro.cap.se>
5 ;; Created: 8 Oct 1993
6 ;; $Revision: 3.21 $
7 ;; $Date: 1994/12/22 07:58:27 $
8 ;; Keywords: mouse buffer menu
9 ;;
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2 of the License, or
13 ;; (at your option) any later version.
14 ;;
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
19 ;;
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program; if not, write to the Free Software
22 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23
24 ;; LCD Archive Entry:
25 ;; msb|Lars Lindberg|Lars.Lindberg@sypro.cap.se|
26 ;; Choose buffer with the mouse.
27 ;; $Date: 1994/12/22 07:58:27 $|$Revision: 3.21 $|~/packages/msb.el.Z|
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.
35 ;;
36 ;; Installation:
37 ;; (require 'msb)
38 ;; Note! You now use msb instead of mouse-buffer-menu.
39 ;;
40 ;; Now try c-mouse-down-1 (Press <CTRL> and mouse button 1 at the
41 ;; same time).
42 ;;
43 ;; Customization:
44 ;; Look at the variable 'msb-menu-cond' for deciding what menus you
45 ;; want. It's not that hard to customize, despite my not-so-good
46 ;; doc-string. Feel free to send me a better doc-string.
47 ;; There are some constants for you to try here:
48 ;; msb--few-menus
49 ;; msb--very-many-menus (default)
50 ;;
51 ;; Look at the variable 'msb-item-handling-function' for customization
52 ;; of the appearance of every menu item. Try for instance setting
53 ;; it to 'msb-alon-item-handler.
54 ;;
55 ;; Look at the variable 'msb-item-sort-function' for customization
56 ;; of sorting the menus. Set it to t for instance, which means no
57 ;; sorting - you will get latest used buffer first.
58 ;;
59 ;; Also check out the variable 'msb-display-invisible-buffers-p'
60
61 ;; Known bugs:
62 ;; - `msb' does not work on a non-X-toolkit Emacs.
63 ;; Future enhancements:
64 ;; - [Mattes] had a suggestion about sorting files by extension.
65 ;; I (Lars Lindberg) think this case could be solved if msb.el was
66 ;; rewritten to handle more dynamic splitting. It's now completely
67 ;; static, depending on the menu-cond. If the splitting could also
68 ;; be done by a user-defined function a lot of cases would be
69 ;; solved.
70 ;; - [Jim] suggested that the Frame menu became a part of the buffer menu.
71
72 ;;; Change Log
73 ;; 3.21 22/12-94
74 ;; Fixed bug that occured in non X-toolkit versions of Emacs.
75 ;; [Chalupsky] pointed out that a global `save-match-data' is
76 ;; necessary.
77 ;; Bug found. Thanks [kifer].
78 ;; 3.16 20/12-94
79 ;; Added separators to the menu. New variable `msb-separator-diff'.
80 ;; New variable `msb-files-by-directory-sort-key'.
81 ;; Removed `msb--many-menus.'
82 ;; Fixed bugs.
83 ;; 3.13 20/12-94
84 ;; Menu fix for non-X-toolkit Emacsen and new "process"
85 ;; menu. Thanks [jim].
86 ;; Bug for 'files-by-type'.
87 ;; Restored the call to `msb-after-load-hooks'. Thanks [larry].
88 ;; Major fixes by [Ake].
89 ;; Menu-bar buffer-menu now has menu-toggle at top level.
90 ;; 3.6 16/12-94
91 ;; Added variable `msb-max-file-menu-items'.
92 ;; Removed a large part of the change log.
93 ;; Found bug.
94 ;; 3.3 16/12-94
95 ;; Found bugs.
96 ;; 3.1 16/12-94
97 ;; Now has two types of menus - "files by directory" and "files
98 ;; by type".
99 ;; Added variable `msb-files-by-directory'.
100 ;; Fixed a number of bugs for older versions.
101 ;; 2.11 16/12-94
102 ;; Added 'no-multi to msb-menu-cond.
103 ;; Added possibility to shift the menu leftwards. Thanks [kifer].
104 ;; 2.8 15/12-94
105 ;; Now aware of earlier versions of Emacs that doesn't have the
106 ;; function `frame-or-buffer-changed-p' or the variable
107 ;; `menu-bar-update-hook'. Thanks [will].
108 ;; 2.7 14/12-94
109 ;; Better installation.
110 ;; 2.6 14/12-94
111 ;; Now only makes up the menu when necessary.
112 ;; Added menu-bar support.
113 ;; Now handles errors in msb-menu-cond better. Thanks [jaalto].
114 ;; Added MH-awareness. Thanks [kifer].
115 ;; Added autoload statements.
116 ;; 2.3 8/12-94
117 ;; Now uses RCS version numbering for msb.el version number.
118 ;; Submitted this to LCD.
119
120 ;;; Thanks goes to
121 ;; [msb] - Mark Brader <msb@sq.com>
122 ;; [Chalupsky] - Hans Chalupsky <hans@cs.Buffalo.EDU>
123 ;; [jim] - Jim Berry <m1jhb00@FRB.GOV>
124 ;; [larry] - Larry Rosenberg <ljr@ictv.com>
125 ;; [will] - Will Henney <will@astroscu.unam.mx>
126 ;; [jaalto] - Jari Aalto <jaalto@tre.tele.nokia.fi>
127 ;; [kifer] - Michael Kifer <kifer@sbkifer.cs.sunysb.edu>
128 ;; [Gael] - Gael Marziou <gael@gnlab030.grenoble.hp.com>
129 ;; [Gillespie] - Dave Gillespie <daveg@thymus.synaptics.com>
130 ;; [Alon] - Alon Albert <alon@milcse.rtsg.mot.com>
131 ;; [KevinB] - Kevin Broadey, <KevinB@bartley.demon.co.uk>
132 ;; [Ake] - Ake Stenhof <ake@cadpoint.se>
133 ;; [RMS] - Richard Stallman <rms@gnu.ai.mit.edu>
134 ;; [Fisk] - Steve Fisk <fisk@medved.bowdoin.edu>
135
136 ;;; Code:
137
138 (require 'cl)
139
140 ;;;
141 ;;; Some example constants to be used for 'msb-menu-cond'. See that
142 ;;; variable for more information. Please note that if the condition
143 ;;; returns 'multi, then the buffer can appear in several menus.
144 ;;;
145 (defconst msb--few-menus
146 '(((and (boundp 'server-buffer-clients)
147 server-buffer-clients
148 'multi)
149 3030
150 "Clients (%d)")
151 ((and msb-display-invisible-buffers-p
152 (msb-invisible-buffer-p)
153 'multi)
154 3090
155 "Invisible buffers (%d)")
156 ((eq major-mode 'dired-mode)
157 2010
158 "Dired (%d)"
159 msb-dired-item-handler
160 msb-sort-by-directory)
161 ((eq major-mode 'Man-mode)
162 4090
163 "Manuals (%d)")
164 ((eq major-mode 'w3-mode)
165 4020
166 "WWW (%d)")
167 ((or (memq major-mode '(rmail-mode vm-summary-mode vm-mode mail-mode))
168 (memq major-mode '(mh-letter-mode
169 mh-show-mode
170 mh-folder-mode))
171 (memq major-mode '(gnus-summary-mode
172 news-reply-mode
173 gnus-group-mode
174 gnus-article-mode
175 gnus-kill-file-mode
176 gnus-browse-killed-mode)))
177 4010
178 "Mail (%d)")
179 ((not buffer-file-name)
180 4099
181 "Buffers (%d)")
182 ('no-multi
183 1099
184 "Files (%d)")))
185
186 (defconst msb--very-many-menus
187 '(((and (boundp 'server-buffer-clients)
188 server-buffer-clients
189 'multi)
190 1010
191 "Clients (%d)")
192 ((and (boundp 'vc-mode) vc-mode 'multi)
193 1020
194 "Version Control (%d)")
195 ((and buffer-file-name
196 (buffer-modified-p)
197 'multi)
198 1030
199 "Changed files (%d)")
200 ((and (get-buffer-process (current-buffer))
201 'multi)
202 1040
203 "Processes (%d)")
204 ((and msb-display-invisible-buffers-p
205 (msb-invisible-buffer-p)
206 'multi)
207 1090
208 "Invisible buffers (%d)")
209 ((eq major-mode 'dired-mode)
210 2010
211 "Dired (%d)"
212 ;; Note this different menu-handler
213 msb-dired-item-handler
214 ;; Also note this item-sorter
215 msb-sort-by-directory)
216 ((eq major-mode 'Man-mode)
217 4030
218 "Manuals (%d)")
219 ((eq major-mode 'w3-mode)
220 4020
221 "WWW (%d)")
222 ((or (memq major-mode '(rmail-mode vm-summary-mode vm-mode mail-mode))
223 (memq major-mode '(mh-letter-mode
224 mh-show-mode
225 mh-folder-mode))
226 (memq major-mode '(gnus-summary-mode
227 news-reply-mode
228 gnus-group-mode
229 gnus-article-mode
230 gnus-kill-file-mode
231 gnus-browse-killed-mode)))
232 4010
233 "Mail (%d)")
234 ;; Catchup for all non-file buffers
235 ((and (not buffer-file-name)
236 'no-multi)
237 4099
238 "Other non-file buffers (%d)")
239 ((and (string-match "/\\.[^/]*$" buffer-file-name)
240 'multi)
241 3090
242 "Hidden Files (%d)")
243 ((memq major-mode '(c-mode c++-mode))
244 3010
245 "C/C++ Files (%d)")
246 ((eq major-mode 'emacs-lisp-mode)
247 3020
248 "Elisp Files (%d)")
249 ((eq major-mode 'latex-mode)
250 3030
251 "LaTex Files (%d)")
252 ('no-multi
253 3099
254 "Other files (%d)")))
255
256 ;; msb--many-menus is obsolete
257 (defvar msb--many-menus msb--very-many-menus)
258
259 ;;;
260 ;;; Customizable variables
261 ;;;
262
263 (defvar msb-separator-diff 100
264 "*Non-nil means use separators.
265 The separators will appear between all menus that have a sorting key that differs by this value or more.")
266
267 (defvar msb-files-by-directory-sort-key 0
268 "*The sort key for files sorted by directory")
269
270 (defvar msb-max-menu-items 25
271 "*The maximum number of items in a menu.
272 If this variable is set to 15 for instance, then the 15 latest used
273 buffer that fits in a certain submenu will appear in that submenu.
274 Nil means no limit.")
275
276 (defvar msb-max-file-menu-items 10
277 "*The maximum number of items from different directories.
278
279 When the menu is of type 'file by directory', this is the maximum
280 number of buffers that are clumped togehter from different
281 directories.
282
283 If the value is not a number, then the value 10 is used.")
284
285 (defvar msb-most-recently-used-sort-key -1010
286 "*Where should the menu with the most recently used buffers be placed?")
287
288 (defvar msb-display-most-recently-used t
289 "*How many buffers should be in the most-recently-used menu.
290 No buffers at all if less than 1 or nil.
291 T means use the value of `msb-max-menu-items' in the way it is defined.")
292
293 (defvar msb-most-recently-used-title "Most recently used (%d)"
294 "*The title for the most-recently-used menu.")
295
296 (defvar msb-horizontal-shift-function '(lambda () 0)
297 "*Function that specifies a number of pixels by which the top menu should
298 be shifted leftwards.")
299
300 (defvar msb-display-invisible-buffers-p nil
301 "*Show invisible buffers or not.
302 Non-nil means that the buffer menu should include buffers that have
303 names that starts with a space character.")
304
305 (defvar msb-item-handling-function 'msb-item-handler
306 "*The appearance of a buffer menu.
307
308 The default function to call for handling the appearance of a menu
309 item. It should take to arguments, BUFFER and MAX-BUFFER-NAME-LENGTH,
310 where the latter is the max length of all buffer names.
311 When the function is called, BUFFER is the current buffer.
312 This function is called for items in the variable 'msb-menu-cond' that
313 have nil as ITEM-HANDLING-FUNCTION. See 'msb-menu-cond' for more
314 information.")
315
316 (defvar msb-item-sort-function 'msb-sort-by-name
317 "*The order of items in a buffer menu.
318 The default function to call for handling the order of items in a menu
319 item. This function is called like a sort function. The items
320 look like (ITEM-NAME . BUFFER).
321 ITEM-NAME is the name of the item that will appear in the menu.
322 BUFFER is the buffer, this is not necessarily the current buffer.
323
324 Set this to nil or t if you don't want any sorting (faster).")
325
326 (defvar msb-files-by-directory nil
327 "*Non-nil means that files should be sorted by directory instead of
328 the groups in msb-menu-cond.")
329
330 (defvar msb-menu-cond msb--very-many-menus
331 "*List of criterias for splitting the mouse buffer menu.
332 The elements in the list should be of this type:
333 (CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLING-FN ITEM-SORT-FN).
334
335 When making the split, the buffers are tested one by one against the
336 CONDITION, just like a lisp cond: When hitting a true condition, the
337 other criterias are *not* tested and the buffer name will appear in
338 the menu with the menu-title corresponding to the true condition.
339
340 If the condition returns the symbol 'multi, then the buffer will be
341 added to this menu *and* tested for other menus too. If it returns
342 'no-multi, then the buffer will only be added if it hasn't been added
343 to any other menu.
344
345 During this test, the buffer in question is the current buffer, and
346 the test is surrounded by calls to `save-excursion' and
347 `save-match-data'
348
349 The categories are sorted by MENU-SORT-KEY. Smaller keys are on
350 top. nil means don't display this menu.
351
352 MENU-TITLE is really a format. If you add %d in it, the %d is replaced
353 with the number of items in that menu.
354
355 ITEM-HANDLING-FN, is optional. If it is supplied and is a
356 function, than it is used for displaying the items in that particular
357 buffer menu, otherwise the function pointed out by
358 'msb-item-handling-function' is used.
359
360 ITEM-SORT-FN, is also optional.
361 If it is not supplied, the function pointed out by
362 'msb-item-sort-function' is used.
363 If it is nil, then no sort takes place and the buffers are presented
364 in least-recently-used order.
365 If it is t, then no sort takes place and the buffers are presented in
366 most-recently-used order.
367 If it is supplied and non-nil and not t than it is used for sorting
368 the items in that particular buffer menu.
369
370 Note1: There should always be a 'catch-all' as last element,
371 in this list. That is an element like (t TITLE ITEM-HANDLING-FUNCTION).
372 Note2: A buffer menu appears only if it has at least one buffer in it.
373 Note3: If you have a CONDITION that can't be evaluated you will get an
374 error every time you do \\[msb].")
375
376 (defvar msb-after-load-hooks nil
377 "Hooks to be run after the msb package has been loaded.")
378
379 ;;;
380 ;;; Internal variables
381 ;;;
382
383 ;; The last calculated menu.
384 (defvar msb--last-buffer-menu nil)
385
386 ;; If this is non-nil, then it is a string that describes the error.
387 (defvar msb--error nil)
388
389 ;;;
390 ;;; Some example function to be used for 'msb-item-sort-function'.
391 ;;;
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)))
403
404
405 (eval-when-compile (require 'dired))
406
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))))
414 (t
415 (error "Unknown type of 'dired-directory' in buffer %s"
416 (buffer-name)))))
417
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)))
429
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 "")))
443
444 ;;;
445 ;;; Some example function to be used for 'msb-item-handling-function'.
446 ;;;
447 (defun msb-sort-by-name (item1 item2)
448 "Sorts the items depending on their buffer-name
449 An item look like (NAME . BUFFER)."
450 (string-lessp (buffer-name (cdr item1))
451 (buffer-name (cdr item2))))
452
453
454 (defun msb-sort-by-directory (item1 item2)
455 "Sorts the items depending on their directory. Made for dired.
456 An item look like (NAME . BUFFER)."
457 (string-lessp (save-excursion (set-buffer (cdr item1)) (msb--dired-directory))
458 (save-excursion (set-buffer (cdr item2)) (msb--dired-directory))))
459
460 ;;;
461 ;;; msb
462 ;;;
463 ;;; This function can be used instead of (mouse-buffer-menu EVENT)
464 ;;; function in "mouse.el".
465 ;;;
466 (defun msb (event)
467 "Pop up several menus of buffers for selection with the mouse.
468 This command switches buffers in the window that you clicked on, and
469 selects that window.
470
471 See the function 'mouse-select-buffer' and the variable
472 'msb-menu-cond' for more information about how the menus are split."
473 (interactive "e")
474 (let ((buffer (mouse-select-buffer event))
475 (window (posn-window (event-start event))))
476 (cond
477 (buffer
478 (or (framep window) (select-window window))
479 (switch-to-buffer (car (cdr buffer))))))
480 nil)
481
482 ;;;
483 ;;; Some supportive functions
484 ;;;
485 (defun msb-invisible-buffer-p (&optional buffer)
486 "Return t if optional BUFFER is an \"invisible\" buffer.
487 If the argument is left out or nil, then the current buffer is considered."
488 (and (> (length (buffer-name buffer)) 0)
489 (eq ?\ (aref (buffer-name buffer) 0))))
490
491 ;; Strip one hierarcy level from the end of PATH.
492 (defun msb--strip-path (path)
493 (save-match-data
494 (if (string-match "\\(.+\\)/[^/]+$" path)
495 (substring path (match-beginning 1) (match-end 1))
496 "/")))
497
498 ;; Create an alist with all buffers from LIST that lies under the same
499 ;; directory will be in the same item as the directory string as
500 ;;'((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K BUFFER-K+1...)) ...)
501 (defun msb--init-file-alist (list)
502 (let ((buffer-alist
503 (sort (mapcan
504 (function
505 (lambda (buffer)
506 (let ((file-name (buffer-file-name buffer)))
507 (when file-name
508 (list (cons (msb--strip-path file-name) buffer))))))
509 list)
510 (function (lambda (item1 item2)
511 (string< (car item1) (car item2)))))))
512 ;; Make alist that looks like
513 ;;'((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K)) ...)
514 (let ((path nil)
515 (buffers nil)
516 (result nil))
517 (append
518 (mapcan (function
519 (lambda (item)
520 (cond
521 ((and path
522 msb-max-menu-items
523 (< (length buffers) msb-max-menu-items)
524 (string= path (car item)))
525 (push (cdr item) buffers)
526 nil)
527 (t
528 (when path
529 (setq result (cons path buffers)))
530 (setq path (car item))
531 (setq buffers (list (cdr item)))
532 (and result (list result))))))
533 buffer-alist)
534 (list (cons path buffers))))))
535
536 ;; Choose file-menu with respect to directory for every buffer in LIST.
537 (defun msb--choose-file-menu (list)
538 (let ((buffer-alist (msb--init-file-alist list))
539 (final-list nil)
540 (max-clumped-together (if (numberp msb-max-file-menu-items)
541 msb-max-file-menu-items
542 10))
543 (top-found-p nil)
544 (last-path nil)
545 first rest path buffers)
546 (setq first (car buffer-alist))
547 (setq rest (cdr buffer-alist))
548 (setq path (car first))
549 (setq buffers (cdr first))
550 (while rest
551 (let ((found-p nil)
552 (tmp-rest rest)
553 new-path item)
554 (setq item (car tmp-rest))
555 (while (and tmp-rest
556 (<= (length buffers) max-clumped-together)
557 (>= (length (car item)) (length path))
558 (string= path (substring (car item) 0 (length path))))
559 (setq found-p t)
560 (setq buffers (append buffers (cdr item)))
561 (setq tmp-rest (cdr tmp-rest))
562 (setq item (car tmp-rest)))
563 (cond
564 ((> (length buffers) max-clumped-together)
565 (setq last-path (car first))
566 (when top-found-p
567 (setq first (cons (concat (car first) "/...")
568 (cdr first)))
569 (setq top-found-p nil))
570 (push first final-list)
571 (setq first (car rest)
572 rest (cdr rest))
573 (setq path (car first)
574 buffers (cdr first)))
575 (t
576 (when found-p
577 (setq top-found-p t)
578 (setq first (cons path buffers)
579 rest tmp-rest))
580 (setq path (msb--strip-path path)
581 buffers (cdr first))
582 (when (and last-path
583 (or (and (>= (length path) (length last-path))
584 (string= last-path
585 (substring path 0 (length last-path))))
586 (and (< (length path) (length last-path))
587 (string= path
588 (substring last-path 0 (length path))))))
589
590 (when top-found-p
591 (setq first (cons (concat (car first) "/...")
592 (cdr first)))
593 (setq top-found-p nil))
594 (push first final-list)
595 (setq first (car rest)
596 rest (cdr rest))
597 (setq path (car first)
598 buffers (cdr first)))))))
599 (when top-found-p
600 (setq first (cons (concat (car first)
601 (if (string-match "/$" (car first))
602 "..."
603 "/..."))
604 (cdr first)))
605 (setq top-found-p nil))
606 (push first final-list)
607 (nreverse final-list)))
608
609 ;; Create a vector as:
610 ;; [BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER)
611 ;; from an element in 'msb-menu-cond'. See that variable for a
612 ;; description of it's elements.
613 (defun msb--create-function-info (menu-cond-elt)
614 (let* ((list-symbol (make-symbol "-msb-buffer-list"))
615 (tmp-ih (and (> (length menu-cond-elt) 3)
616 (nth 3 menu-cond-elt)))
617 (item-handler (if (and tmp-ih (fboundp tmp-ih))
618 tmp-ih
619 msb-item-handling-function))
620 (tmp-s (if (> (length menu-cond-elt) 4)
621 (nth 4 menu-cond-elt)
622 msb-item-sort-function))
623 (sorter (if (or (fboundp tmp-s)
624 (null tmp-s)
625 (eq tmp-s 't))
626 tmp-s
627 msb-item-sort-function)))
628 (when (< (length menu-cond-elt) 3)
629 (error "Wrong format of msb-menu-cond."))
630 (when (and (> (length menu-cond-elt) 3)
631 (not (fboundp tmp-ih)))
632 (signal 'invalid-function (list tmp-ih)))
633 (when (and (> (length menu-cond-elt) 4)
634 tmp-s
635 (not (fboundp tmp-s))
636 (not (eq tmp-s 't)))
637 (signal 'invalid-function (list tmp-s)))
638 (set list-symbol '())
639 (vector list-symbol ;BUFFER-LIST-VARIABLE
640 (nth 0 menu-cond-elt) ;CONDITION
641 (nth 1 menu-cond-elt) ;SORT-KEY
642 (nth 2 menu-cond-elt) ;MENU-TITLE
643 item-handler ;ITEM-HANDLER
644 sorter) ;SORTER
645 ))
646
647 ;; This defsubst is only used in `msb--choose-menu' below. It was
648 ;; pulled out merely to make the code somewhat clearer. The indention
649 ;; level was too big.
650 (defsubst msb--collect (function-info-vector)
651 (let ((result nil)
652 (multi-flag nil)
653 function-info-list)
654 (setq function-info-list
655 (loop for fi
656 across function-info-vector
657 if (and (setq result
658 (eval (aref fi 1))) ;Test CONDITION
659 (not (and (eq result 'no-multi)
660 multi-flag))
661 (progn (when (eq result 'multi)
662 (setq multi-flag t))
663 t)
664 (or (not msb-max-menu-items)
665 (< (length (eval (aref fi 0)))
666 msb-max-menu-items)))
667 collect fi
668 until (and result
669 (not (eq result 'multi)))))
670 (when (and (not function-info-list)
671 (not result))
672 (error "No catch-all in msb-menu-cond!"))
673 function-info-list))
674
675 ;; Adds BUFFER to the menu depicted by FUNCTION-INFO
676 ;; All side-effects. Adds an element of type '(BUFFER-TITLE . BUFFER)
677 ;; to the buffer-list variable in function-info.
678 (defun msb--add-to-menu (buffer function-info max-buffer-name-length)
679 (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
680 ;; Here comes the hairy side-effect!
681 (set list-symbol
682 (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
683 buffer
684 max-buffer-name-length)
685 buffer)
686 (eval list-symbol)))))
687
688 ;; Selects the appropriate menu for BUFFER.
689 ;; This is all side-effects, folks!
690 ;; This should be optimized.
691 (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
692 (unless (and (not msb-display-invisible-buffers-p)
693 (msb-invisible-buffer-p buffer))
694 (condition-case nil
695 (save-excursion
696 (set-buffer buffer)
697 ;; Menu found. Add to this menu
698 (mapc (function
699 (lambda (function-info)
700 (msb--add-to-menu buffer function-info max-buffer-name-length)))
701 (msb--collect function-info-vector)))
702 (error (unless msb--error
703 (setq msb--error
704 (format
705 "Variable `msb-menu-cond': Error for buffer \"%s\"."
706 (buffer-name buffer)))
707 (error msb--error))))))
708
709 ;; Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the
710 ;; buffer-list is empty.
711 (defun msb--create-sort-item (function-info)
712 (let ((buffer-list (eval (aref function-info 0))))
713 (when buffer-list
714 (let ((sorter (aref function-info 5)) ;SORTER
715 (sort-key (aref function-info 2))) ;MENU-SORT-KEY
716 (when sort-key
717 (cons sort-key
718 (cons (format (aref function-info 3) ;MENU-TITLE
719 (length buffer-list))
720 (cond
721 ((null sorter)
722 buffer-list)
723 ((eq sorter 't)
724 (nreverse buffer-list))
725 (t
726 (sort buffer-list sorter))))))))))
727
728 ;; Returns a list on the form ((TITLE . BUFFER-LIST)) for
729 ;; the most recently used buffers.
730 (defun msb--most-recently-used-menu (max-buffer-name-length)
731 (when (and msb-display-most-recently-used
732 (or (not (numberp msb-display-most-recently-used))
733 (> msb-display-most-recently-used 0)))
734 (let* ((max-in-menu
735 (if (numberp msb-display-most-recently-used)
736 msb-display-most-recently-used
737 msb-max-menu-items))
738
739 (most-recently-used
740 (loop with n = 0
741 for buffer in (cdr (buffer-list))
742 if (save-excursion
743 (set-buffer buffer)
744 (and (not (msb-invisible-buffer-p))
745 (not (eq major-mode 'dired-mode))))
746 collect (save-excursion
747 (set-buffer buffer)
748 (cons (funcall msb-item-handling-function
749 buffer
750 max-buffer-name-length)
751 buffer))
752 and do (incf n)
753 until (and max-in-menu (>= n max-in-menu)))))
754 (cons (if (stringp msb-most-recently-used-title)
755 (format msb-most-recently-used-title
756 (length most-recently-used))
757 (signal 'wrong-type-argument (list msb-most-recently-used-title)))
758 most-recently-used))))
759
760 (defun msb--create-buffer-menu-2 ()
761 (let ((max-buffer-name-length 0)
762 file-buffers
763 function-info-vector)
764 ;; Calculate the longest buffer name.
765 (mapc
766 (function
767 (lambda (buffer)
768 (if (or msb-display-invisible-buffers-p
769 (not (msb-invisible-buffer-p)))
770 (setq max-buffer-name-length
771 (max max-buffer-name-length
772 (length (buffer-name buffer)))))))
773 (buffer-list))
774 ;; Make a list with elements of type
775 ;; (BUFFER-LIST-VARIABLE
776 ;; CONDITION
777 ;; MENU-SORT-KEY
778 ;; MENU-TITLE
779 ;; ITEM-HANDLER
780 ;; SORTER)
781 ;; Uses "function-global" variables:
782 ;; function-info-vector
783 (setq function-info-vector
784 (apply (function vector)
785 (mapcar (function msb--create-function-info)
786 msb-menu-cond)))
787 ;; Split the buffer-list into several lists; one list for each
788 ;; criteria. This is the most critical part with respect to time.
789 (mapc (function (lambda (buffer)
790 (cond ((and msb-files-by-directory
791 (buffer-file-name buffer))
792 (push buffer file-buffers))
793 (t
794 (msb--choose-menu buffer
795 function-info-vector
796 max-buffer-name-length)))))
797 (buffer-list))
798 (when file-buffers
799 (setq file-buffers
800 (mapcar (function
801 (lambda (buffer-list)
802 (cons msb-files-by-directory-sort-key
803 (cons (car buffer-list)
804 (sort
805 (mapcar (function
806 (lambda (buffer)
807 (cons (buffer-name buffer)
808 buffer)))
809 (cdr buffer-list))
810 (function
811 (lambda (item1 item2)
812 (string< (car item1) (car item2)))))))))
813 (msb--choose-file-menu file-buffers))))
814 ;; Now make the menu - a list of (TITLE . BUFFER-LIST)
815 (let* ((buffers (buffer-list))
816 menu
817 (most-recently-used
818 (msb--most-recently-used-menu max-buffer-name-length))
819 (others (append file-buffers
820 (loop for elt
821 across function-info-vector
822 for value = (msb--create-sort-item elt)
823 if value collect value))))
824 (setq menu
825 (mapcar 'cdr ;Remove the SORT-KEY
826 ;; Sort the menus - not the items.
827 (msb--add-separators
828 (sort
829 ;; Get a list of (SORT-KEY TITLE . BUFFER-LIST)
830 ;; Also sorts the items within the menus.
831 (if (cdr most-recently-used)
832 (cons
833 ;; Add most recent used buffers
834 (cons msb-most-recently-used-sort-key
835 most-recently-used)
836 others)
837 others)
838 (function (lambda (elt1 elt2)
839 (< (car elt1) (car elt2))))))))
840 ;; Now make it a keymap menu
841 (append
842 '(keymap "Select Buffer")
843 (msb--make-keymap-menu menu)
844 (when msb-separator-diff
845 (list (list 'separator "---")))
846 (list (cons 'toggle
847 (cons
848 (if msb-files-by-directory
849 "*Files by type*"
850 "*Files by directory*")
851 'msb--toggle-menu-type)))))))
852
853 (defun msb--create-buffer-menu ()
854 (save-match-data
855 (save-excursion
856 (msb--create-buffer-menu-2))))
857
858 ;;;
859 ;;; Multi purpose function for selecting a buffer with the mouse.
860 ;;;
861 (defun msb--toggle-menu-type ()
862 (interactive)
863 (setq msb-files-by-directory (not msb-files-by-directory))
864 (menu-bar-update-buffers t))
865
866 (defun mouse-select-buffer (event)
867 "Pop up several menus of buffers, for selection with the mouse.
868 Returns the selected buffer or nil if no buffer is selected.
869
870 The way the buffers are splitted is conveniently handled with the
871 variable 'msb-menu-cond'."
872 ;; Popup the menu and return the selected buffer.
873 (when (or msb--error
874 (not msb--last-buffer-menu)
875 (not (fboundp 'frame-or-buffer-changed-p))
876 (frame-or-buffer-changed-p))
877 (setq msb--error nil)
878 (setq msb--last-buffer-menu (msb--create-buffer-menu)))
879 (let ((position event))
880 (when (and (fboundp 'posn-x-y)
881 (fboundp 'posn-window))
882 (let ((posX (car (posn-x-y (event-start event))))
883 (posY (cdr (posn-x-y (event-start event))))
884 (posWind (posn-window (event-start event)))
885 name)
886 ;; adjust position
887 (setq posX (- posX (funcall msb-horizontal-shift-function))
888 position (list (list posX posY) posWind))))
889 (setq name (x-popup-menu position msb--last-buffer-menu))
890 ;; If toggle bring up the
891 (cond
892 ((eq (car name) 'toggle)
893 (msb--toggle-menu-type)
894 (mouse-select-buffer event))
895 ((and (numberp (car name))
896 (null (cdr name)))
897 (let ((msb--last-buffer-menu (nthcdr 3 (assq (car name) msb--last-buffer-menu))))
898 (mouse-select-buffer event)))
899 ((and (stringp (car name))
900 (null (cdr name)))
901 (cons nil name))
902 (t
903 name))))
904
905 ;; Add separators
906 (defun msb--add-separators (sorted-list)
907 (cond
908 ((or (not msb-separator-diff)
909 (not (numberp msb-separator-diff)))
910 sorted-list)
911 (t
912 (let ((last-key nil))
913 (mapcan
914 (function
915 (lambda (item)
916 (cond
917 ((and msb-separator-diff
918 last-key
919 (> (- (car item) last-key)
920 msb-separator-diff))
921 (setq last-key (car item))
922 (list (cons last-key 'separator)
923 item))
924 (t
925 (setq last-key (car item))
926 (list item)))))
927 sorted-list)))))
928
929 (defun msb--make-keymap-menu (raw-menu)
930 (let ((end (cons '(nil) 'menu-bar-select-buffer))
931 (mcount 0))
932 (mapcar
933 (function
934 (lambda (sub-menu)
935 (cond
936 ((eq 'separator sub-menu)
937 (list 'separator "---"))
938 (t
939 (append (list (incf mcount) (car sub-menu)
940 'keymap (car sub-menu))
941 (mapcar (function
942 (lambda (item)
943 (let ((string (car item))
944 (buffer (cdr item)))
945 (cons (buffer-name buffer)
946 (cons string end)))))
947 (cdr sub-menu)))))))
948 raw-menu)))
949
950 (defun menu-bar-update-buffers (&optional arg)
951 ;; If user discards the Buffers item, play along.
952 (when (and (lookup-key (current-global-map) [menu-bar buffer])
953 (or (not (fboundp 'frame-or-buffer-changed-p))
954 (frame-or-buffer-changed-p)
955 arg))
956 (let ((buffers (buffer-list))
957 (frames (frame-list))
958 buffers-menu frames-menu)
959 ;; If requested, list only the N most recently selected buffers.
960 (when (and (integerp buffers-menu-max-size)
961 (> buffers-menu-max-size 1)
962 (> (length buffers) buffers-menu-max-size))
963 (setcdr (nthcdr buffers-menu-max-size buffers) nil))
964 ;; Make the menu of buffers proper.
965 (setq msb--last-buffer-menu (msb--create-buffer-menu))
966 (setq buffers-menu msb--last-buffer-menu)
967 ;; Make a Frames menu if we have more than one frame.
968 (if (cdr frames)
969 (setq frames-menu
970 (cons "Select Frame"
971 (mapcar
972 (function
973 (lambda (frame)
974 (nconc
975 (list frame
976 (cdr (assq 'name
977 (frame-parameters frame)))
978 (cons nil nil))
979 'menu-bar-select-frame)))
980 frames))))
981 (when frames-menu
982 (setq frames-menu (cons 'keymap frames-menu)))
983 (define-key (current-global-map) [menu-bar buffer]
984 (cons "Buffers"
985 (if (and buffers-menu frames-menu)
986 (list 'keymap "Buffers and Frames"
987 (cons 'buffers (cons "Buffers" buffers-menu))
988 (cons 'frames (cons "Frames" frames-menu)))
989 (or buffers-menu frames-menu 'undefined)))))))
990
991 (when (and (boundp 'menu-bar-update-hook)
992 (not (fboundp 'frame-or-buffer-changed-p)))
993 (defvar msb--buffer-count 0)
994 (defun frame-or-buffer-changed-p ()
995 (let ((count (length (buffer-list))))
996 (when (/= count msb--buffer-count)
997 (setq msb--buffer-count count)
998 t))))
999
1000 (unless (or (not (boundp 'menu-bar-update-hook))
1001 (memq 'menu-bar-update-buffers menu-bar-update-hook))
1002 (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
1003
1004 (and (fboundp 'mouse-buffer-menu)
1005 (substitute-key-definition 'mouse-buffer-menu 'msb (current-global-map)))
1006
1007 (provide 'msb)
1008 (eval-after-load 'msb (run-hooks 'msb-after-load-hooks))
1009 ;;; msb.el ends here