lisp/msb.el

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