lisp/msb.el

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