lisp/msb.el

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