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                     (eq t (compare-strings path 0 nil
 601                                            (car item) 0 (length path))))
 602           (setq found-p t)
 603           (setq buffers (append buffers (cdr item))) ;nconc is faster than append
 604           (setq tmp-rest (cdr tmp-rest)
 605                 item (car tmp-rest)))
 606         (cond
 607          ((> (length buffers) max-clumped-together)
 608           ;; Oh, we failed. Too many buffers clumped together.
 609           ;; Just use the original ones for the result.
 610           (setq last-path (car first))
 611           (push (cons (msb--format-title top-found-p
 612                                          (car first)
 613                                          (length (cdr first)))
 614                       (cdr first))
 615                 final-list)
 616           (setq top-found-p nil)
 617           (setq first (car rest)
 618                 rest (cdr rest)
 619                 path (car first)
 620                 buffers (cdr first)))
 621          (t
 622           ;; The first pass of clumping together worked out, go ahead
 623           ;; with this result.
 624           (when found-p
 625             (setq top-found-p t)
 626             (setq first (cons path buffers)
 627                   rest tmp-rest))
 628           ;; Now see if we can clump more buffers together if we go up
 629           ;; one step in the file hierarchy.
 630           ;; If path isn't changed by msb--strip-dir, we are looking
 631           ;; at the machine name component of an ange-ftp filename.
 632           (setq old-path path)
 633           (setq path (msb--strip-dir path)
 634                 buffers (cdr first))
 635           (if (equal old-path path)
 636               (setq last-path path))
 637           (when (and last-path
 638                      (or (and (>= (length path) (length last-path))
 639                               (eq t (compare-strings last-path 0 nil
 640                                                      path 0 (length
 641                                                              last-path))))
 642                          (and (< (length path) (length last-path))
 643                               (eq t (compare-strings path 0 nil
 644                                                      last-path 0 (length
 645                                                                   path))))))
 646             ;; We have reached the same place in the file hierarchy as
 647             ;; the last result, so we should quit at this point and
 648             ;; take what we have as result.
 649             (push (cons (msb--format-title top-found-p
 650                                            (car first)
 651                                            (length (cdr first)))
 652                         (cdr first))
 653                   final-list)
 654             (setq top-found-p nil)
 655             (setq first (car rest)
 656                   rest (cdr rest)
 657                   path (car first)
 658                   buffers (cdr first)))))))
 659     ;; Now take care of the last item.
 660     (when first
 661       (push (cons (msb--format-title top-found-p
 662                                      (car first)
 663                                      (length (cdr first)))
 664                   (cdr first))
 665             final-list))
 666     (setq top-found-p nil)
 667     (nreverse final-list)))
 668
 669 (defun msb--create-function-info (menu-cond-elt)
 670   "Create a vector from an element MENU-COND-ELT of `msb-menu-cond'.
 671 This takes the form:
 672 \]BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER)
 673 See `msb-menu-cond' for a description of its elements."
 674   (let* ((list-symbol (make-symbol "-msb-buffer-list"))
 675          (tmp-ih (and (> (length menu-cond-elt) 3)
 676                       (nth 3 menu-cond-elt)))
 677          (item-handler (if (and tmp-ih (fboundp tmp-ih))
 678                            tmp-ih
 679                          msb-item-handling-function))
 680          (tmp-s (if (> (length menu-cond-elt) 4)
 681                     (nth 4 menu-cond-elt)
 682                   msb-item-sort-function))
 683          (sorter (if (or (fboundp tmp-s)
 684                          (null tmp-s)
 685                          (eq tmp-s t))
 686                     tmp-s
 687                    msb-item-sort-function)))
 688     (when (< (length menu-cond-elt) 3)
 689       (error "Wrong format of msb-menu-cond"))
 690     (when (and (> (length menu-cond-elt) 3)
 691                (not (fboundp tmp-ih)))
 692       (signal 'invalid-function (list tmp-ih)))
 693     (when (and (> (length menu-cond-elt) 4)
 694                tmp-s
 695                (not (fboundp tmp-s))
 696                (not (eq tmp-s t)))
 697       (signal 'invalid-function (list tmp-s)))
 698     (set list-symbol ())
 699     (vector list-symbol                 ;BUFFER-LIST-VARIABLE
 700             (nth 0 menu-cond-elt)       ;CONDITION
 701             (nth 1 menu-cond-elt)       ;SORT-KEY
 702             (nth 2 menu-cond-elt)       ;MENU-TITLE
 703             item-handler                ;ITEM-HANDLER
 704             sorter)                     ;SORTER
 705     ))
 706
 707 ;; This defsubst is only used in `msb--choose-menu' below.  It was
 708 ;; pulled out merely to make the code somewhat clearer.  The indentation
 709 ;; level was too big.
 710 (defsubst msb--collect (function-info-vector)
 711   (let ((result nil)
 712         (multi-flag nil)
 713         function-info-list)
 714     (setq function-info-list
 715           (loop for fi
 716                 across function-info-vector
 717                 if (and (setq result
 718                               (eval (aref fi 1))) ;Test CONDITION
 719                         (not (and (eq result 'no-multi)
 720                                   multi-flag))
 721                         (progn (when (eq result 'multi)
 722                                  (setq multi-flag t))
 723                                t))
 724                 collect fi
 725                 until (and result
 726                            (not (eq result 'multi)))))
 727     (when (and (not function-info-list)
 728                (not result))
 729       (error "No catch-all in msb-menu-cond!"))
 730     function-info-list))
 731
 732 (defun msb--add-to-menu (buffer function-info max-buffer-name-length)
 733   "Add BUFFER to the menu depicted by FUNCTION-INFO.
 734 All side-effects.  Adds an element of form (BUFFER-TITLE . BUFFER)
 735 to the buffer-list variable in function-info."
 736   (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
 737     ;; Here comes the hairy side-effect!
 738     (set list-symbol
 739          (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
 740                               buffer
 741                               max-buffer-name-length)
 742                      buffer)
 743                (eval list-symbol)))))
 744
 745 (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
 746   "Select the appropriate menu for BUFFER."
 747   ;; This is all side-effects, folks!
 748   ;; This should be optimized.
 749   (unless (and (not msb-display-invisible-buffers-p)
 750                (msb-invisible-buffer-p buffer))
 751     (condition-case nil
 752         (save-excursion
 753           (set-buffer buffer)
 754           ;; Menu found.  Add to this menu
 755           (mapc (lambda (function-info)
 756                   (msb--add-to-menu buffer function-info max-buffer-name-length))
 757                 (msb--collect function-info-vector)))
 758       (error (unless msb--error
 759                (setq msb--error
 760                      (format
 761                       "In msb-menu-cond, error for buffer `%s'."
 762                       (buffer-name buffer)))
 763                (error "%s" msb--error))))))
 764
 765 (defun msb--create-sort-item (function-info)
 766   "Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the buffer-list is empty."
 767   (let ((buffer-list (eval (aref function-info 0))))
 768     (when buffer-list
 769       (let ((sorter (aref function-info 5)) ;SORTER
 770             (sort-key (aref function-info 2))) ;MENU-SORT-KEY
 771         (when sort-key
 772           (cons sort-key
 773                 (cons (format (aref function-info 3) ;MENU-TITLE
 774                               (length buffer-list))
 775                       (cond
 776                        ((null sorter)
 777                         buffer-list)
 778                        ((eq sorter t)
 779                         (nreverse buffer-list))
 780                        (t
 781                         (sort buffer-list sorter))))))))))
 782
 783 (defun msb--aggregate-alist (alist same-predicate sort-predicate)
 784   "Return ALIST as a sorted, aggregated alist.
 785
 786 In the result all items with the same car element (according to
 787 SAME-PREDICATE) are aggregated together.  The alist is first sorted by
 788 SORT-PREDICATE.
 789
 790 Example:
 791 (msb--aggregate-alist
 792  '((a . a1) (a . a2) (b . b1) (c . c3) (a . a4) (a . a3) (b . b3) (b . b2))
 793  (function string=)
 794  (lambda (item1 item2)
 795    (string< (symbol-name item1) (symbol-name item2))))
 796 results in
 797 ((a a1 a2 a4 a3) (b b1 b3 b2) (c c3))"
 798   (when (not (null alist))
 799     (let (result
 800           same
 801           tmp-old-car
 802           tmp-same
 803           (first-time-p t)
 804           old-car)
 805       (nconc
 806        (mapcan (lambda (item)
 807                  (cond
 808                   (first-time-p
 809                    (push (cdr item) same)
 810                    (setq first-time-p nil)
 811                    (setq old-car (car item))
 812                    nil)
 813                   ((funcall same-predicate (car item) old-car)
 814                    (push (cdr item) same)
 815                    nil)
 816                   (t
 817                    (setq tmp-same same
 818                          tmp-old-car old-car)
 819                    (setq same (list (cdr item))
 820                          old-car (car item))
 821                    (list (cons tmp-old-car (nreverse tmp-same))))))
 822                (sort alist (lambda (item1 item2)
 823                              (funcall sort-predicate (car item1) (car item2)))))
 824        (list (cons old-car (nreverse same)))))))
 825
 826
 827 (defun msb--mode-menu-cond ()
 828   (let ((key msb-modes-key))
 829     (mapcar (lambda (item)
 830               (incf key)
 831               (list `( eq major-mode (quote ,(car item)))
 832                     key
 833                     (concat (cdr item) " (%d)")))
 834             (sort
 835              (let ((mode-list nil))
 836                (mapc (lambda (buffer)
 837                        (save-excursion
 838                          (set-buffer buffer)
 839                          (when (and (not (msb-invisible-buffer-p))
 840                                     (not (assq major-mode mode-list))
 841                                     (push (cons major-mode mode-name)
 842                                           mode-list)))))
 843                      (cdr (buffer-list)))
 844                mode-list)
 845              (lambda (item1 item2)
 846                (string< (cdr item1) (cdr item2)))))))
 847
 848 (defun msb--most-recently-used-menu (max-buffer-name-length)
 849   "Return a list for the most recently used buffers.
 850 It takes the form ((TITLE . BUFFER-LIST)...)."
 851   (when (and (numberp msb-display-most-recently-used)
 852              (> msb-display-most-recently-used 0))
 853     (let* ((buffers (cdr (buffer-list)))
 854            (most-recently-used
 855             (loop with n = 0
 856                   for buffer in buffers
 857                   if (save-excursion
 858                        (set-buffer buffer)
 859                        (and (not (msb-invisible-buffer-p))
 860                             (not (eq major-mode 'dired-mode))))
 861                   collect (save-excursion
 862                             (set-buffer buffer)
 863                             (cons (funcall msb-item-handling-function
 864                                            buffer
 865                                            max-buffer-name-length)
 866                                   buffer))
 867                   and do (incf n)
 868                   until (>= n msb-display-most-recently-used))))
 869       (cons (if (stringp msb-most-recently-used-title)
 870                 (format msb-most-recently-used-title
 871                         (length most-recently-used))
 872               (signal 'wrong-type-argument (list msb-most-recently-used-title)))
 873             most-recently-used))))
 874
 875 (defun msb--create-buffer-menu-2 ()
 876   (let ((max-buffer-name-length 0)
 877         file-buffers
 878         function-info-vector)
 879     ;; Calculate the longest buffer name.
 880     (mapc
 881      (lambda (buffer)
 882        (if (or msb-display-invisible-buffers-p
 883                (not (msb-invisible-buffer-p)))
 884            (setq max-buffer-name-length
 885                  (max max-buffer-name-length
 886                       (length (buffer-name buffer))))))
 887      (buffer-list))
 888     ;; Make a list with elements of type
 889     ;; (BUFFER-LIST-VARIABLE
 890     ;;  CONDITION
 891     ;;  MENU-SORT-KEY
 892     ;;  MENU-TITLE
 893     ;;  ITEM-HANDLER
 894     ;;  SORTER)
 895     ;; Uses "function-global" variables:
 896     ;; function-info-vector
 897     (setq function-info-vector
 898           (apply (function vector)
 899                  (mapcar (function msb--create-function-info)
 900                          (append msb-menu-cond (msb--mode-menu-cond)))))
 901     ;; Split the buffer-list into several lists; one list for each
 902     ;; criteria.  This is the most critical part with respect to time.
 903     (mapc (lambda (buffer)
 904             (cond ((and msb-files-by-directory
 905                         (buffer-file-name buffer)
 906                         ;; exclude ange-ftp buffers
 907                         ;;(not (string-match "\\/[^/:]+:"
 908                         ;;                 (buffer-file-name buffer)))
 909                         )
 910                    (push buffer file-buffers))
 911                   (t
 912                    (msb--choose-menu buffer
 913                                      function-info-vector
 914                                      max-buffer-name-length))))
 915           (buffer-list))
 916     (when file-buffers
 917       (setq file-buffers
 918             (mapcar (lambda (buffer-list)
 919                       (cons msb-files-by-directory-sort-key
 920                             (cons (car buffer-list)
 921                                   (sort
 922                                    (mapcar (function
 923                                             (lambda (buffer)
 924                                               (cons (save-excursion
 925                                                       (set-buffer buffer)
 926                                                       (funcall msb-item-handling-function
 927                                                                buffer
 928                                                                max-buffer-name-length))
 929                                                     buffer)))
 930                                            (cdr buffer-list))
 931                                    (function
 932                                     (lambda (item1 item2)
 933                                       (string< (car item1) (car item2))))))))
 934                      (msb--choose-file-menu file-buffers))))
 935     ;; Now make the menu - a list of (TITLE . BUFFER-LIST)
 936     (let* (menu
 937            (most-recently-used
 938             (msb--most-recently-used-menu max-buffer-name-length))
 939            (others (nconc file-buffers
 940                            (loop for elt
 941                                  across function-info-vector
 942                                  for value = (msb--create-sort-item elt)
 943                                  if value collect value))))
 944       (setq menu
 945             (mapcar 'cdr                ;Remove the SORT-KEY
 946                     ;; Sort the menus - not the items.
 947                     (msb--add-separators
 948                     (sort
 949                      ;; Get a list of (SORT-KEY TITLE . BUFFER-LIST)
 950                      ;; Also sorts the items within the menus.
 951                      (if (cdr most-recently-used)
 952                          (cons
 953                           ;; Add most recent used buffers
 954                           (cons msb-most-recently-used-sort-key
 955                                 most-recently-used)
 956                           others)
 957                        others)
 958                      (lambda (elt1 elt2)
 959                        (< (car elt1) (car elt2)))))))
 960       ;; Now make it a keymap menu
 961       (append
 962        '(keymap "Select Buffer")
 963        (msb--make-keymap-menu menu)
 964        (when msb-separator-diff
 965          (list (list 'separator "--")))
 966        (list (cons 'toggle
 967                    (cons
 968                    (if msb-files-by-directory
 969                        "*Files by type*"
 970                      "*Files by directory*")
 971                    'msb--toggle-menu-type)))))))
 972
 973 (defun msb--create-buffer-menu  ()
 974   (save-match-data
 975     (save-excursion
 976       (msb--create-buffer-menu-2))))
 977
 978 (defun msb--toggle-menu-type ()
 979   "Multi purpose function for selecting a buffer with the mouse."
 980   (interactive)
 981   (setq msb-files-by-directory (not msb-files-by-directory))
 982   ;; This gets a warning, but it is correct,
 983   ;; because this file redefines menu-bar-update-buffers.
 984   (msb-menu-bar-update-buffers t))
 985
 986 (defun mouse-select-buffer (event)
 987   "Pop up several menus of buffers, for selection with the mouse.
 988 Returns the selected buffer or nil if no buffer is selected.
 989
 990 The way the buffers are split is conveniently handled with the
 991 variable `msb-menu-cond'."
 992   ;; Popup the menu and return the selected buffer.
 993   (when (or msb--error
 994             (not msb--last-buffer-menu)
 995             (not (fboundp 'frame-or-buffer-changed-p))
 996             (frame-or-buffer-changed-p))
 997     (setq msb--error nil)
 998     (setq msb--last-buffer-menu (msb--create-buffer-menu)))
 999   (let ((position event)
1000         choice)
1001     (when (and (fboundp 'posn-x-y)
1002                (fboundp 'posn-window))
1003       (let ((posX (car (posn-x-y (event-start event))))
1004             (posY (cdr (posn-x-y (event-start event))))
1005             (posWind (posn-window (event-start event))))
1006         ;; adjust position
1007         (setq posX (- posX (funcall msb-horizontal-shift-function))
1008               position (list (list posX posY) posWind))))
1009     ;; This `sit-for' magically makes the menu stay up if the mouse
1010     ;; button is released within 0.1 second.
1011     (sit-for 0 100)
1012     ;; Popup the menu
1013     (setq choice (x-popup-menu position msb--last-buffer-menu))
1014     (cond
1015      ((eq (car choice) 'toggle)
1016       ;; Bring up the menu again with type toggled.
1017       (msb--toggle-menu-type)
1018       (mouse-select-buffer event))
1019      ((and (numberp (car choice))
1020            (null (cdr choice)))
1021       (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice) msb--last-buffer-menu))))
1022         (mouse-select-buffer event)))
1023      ((while (numberp (car choice))
1024         (setq choice (cdr choice))))
1025      ((and (stringp (car choice))
1026            (null (cdr choice)))
1027       (car choice))
1028      ((null choice)
1029       choice)
1030      (t
1031       (error "Unknown form for buffer: %s" choice)))))
1032
1033 ;; Add separators
1034 (defun msb--add-separators (sorted-list)
1035   (cond
1036    ((or (not msb-separator-diff)
1037         (not (numberp msb-separator-diff)))
1038     sorted-list)
1039    (t
1040     (let ((last-key nil))
1041       (mapcan
1042        (lambda (item)
1043          (cond
1044           ((and msb-separator-diff
1045                 last-key
1046                 (> (- (car item) last-key)
1047                    msb-separator-diff))
1048            (setq last-key (car item))
1049            (list (cons last-key 'separator)
1050                  item))
1051           (t
1052            (setq last-key (car item))
1053            (list item))))
1054        sorted-list)))))
1055
1056 (defun msb--split-menus-2 (list mcount result)
1057   (cond
1058    ((> (length list) msb-max-menu-items)
1059     (let ((count 0)
1060           sub-name
1061           (tmp-list nil))
1062       (while (< count msb-max-menu-items)
1063         (push (pop list) tmp-list)
1064         (incf count))
1065     (setq tmp-list (nreverse tmp-list))
1066     (setq sub-name (concat (car (car tmp-list)) "..."))
1067     (push (nconc (list mcount sub-name
1068                        'keymap sub-name)
1069                   tmp-list)
1070           result))
1071     (msb--split-menus-2 list (1+ mcount) result))
1072    ((null result)
1073     list)
1074    (t
1075     (let (sub-name)
1076       (setq sub-name (concat (car (car list)) "..."))
1077       (push (nconc (list mcount sub-name
1078                          'keymap sub-name)
1079                   list)
1080           result))
1081     (nreverse result))))
1082
1083 (defun msb--split-menus (list)
1084   (if (and (integerp msb-max-menu-items)
1085            (> msb-max-menu-items 0))
1086       (msb--split-menus-2 list 0 nil)
1087     list))
1088
1089 (defun msb--make-keymap-menu (raw-menu)
1090   (let ((end (cons '(nil) 'menu-bar-select-buffer))
1091         (mcount 0))
1092     (mapcar
1093      (lambda (sub-menu)
1094        (cond
1095         ((eq 'separator sub-menu)
1096          (list 'separator "--"))
1097         (t
1098          (let ((buffers (mapcar (function
1099                                  (lambda (item)
1100                                    (let ((string (car item))
1101                                          (buffer (cdr item)))
1102                                      (cons (buffer-name buffer)
1103                                            (cons string end)))))
1104                                 (cdr sub-menu))))
1105            (nconc (list (incf mcount) (car sub-menu)
1106                         'keymap (car sub-menu))
1107                   (msb--split-menus buffers))))))
1108      raw-menu)))
1109
1110 (defun msb-menu-bar-update-buffers (&optional arg)
1111   "A re-written version of `menu-bar-update-buffers'."
1112   ;; If user discards the Buffers item, play along.
1113   (when (and (lookup-key (current-global-map) [menu-bar buffer])
1114              (or (not (fboundp 'frame-or-buffer-changed-p))
1115                  (frame-or-buffer-changed-p)
1116                  arg))
1117     (let ((frames (frame-list))
1118           buffers-menu frames-menu)
1119       ;; Make the menu of buffers proper.
1120       (setq msb--last-buffer-menu (msb--create-buffer-menu))
1121       (setq buffers-menu msb--last-buffer-menu)
1122       ;; Make a Frames menu if we have more than one frame.
1123       (when (cdr frames)
1124         (let* ((frame-length (length frames))
1125                (f-title  (format "Frames (%d)" frame-length)))
1126           ;; List only the N most recently selected frames
1127           (when (and (integerp msb-max-menu-items)
1128                      (>  msb-max-menu-items 1)
1129                      (> frame-length msb-max-menu-items))
1130             (setcdr (nthcdr msb-max-menu-items frames) nil))
1131           (setq frames-menu
1132                 (nconc
1133                  (list 'frame f-title '(nil) 'keymap f-title)
1134                  (mapcar
1135                   (lambda (frame)
1136                     (nconc
1137                      (list frame
1138                            (cdr (assq 'name
1139                                       (frame-parameters frame)))
1140                            (cons nil nil))
1141                      'menu-bar-select-frame))
1142                   frames)))))
1143       (define-key (current-global-map) [menu-bar buffer]
1144         (cons "Buffers"
1145               (if (and buffers-menu frames-menu)
1146                   ;; Combine Frame and Buffers menus with separator between
1147                   (nconc (list 'keymap "Buffers and Frames" frames-menu
1148                                (and msb-separator-diff '(separator "--")))
1149                          (cddr buffers-menu))
1150                 (or buffers-menu 'undefined)))))))
1151
1152 ;; Snarf current bindings of `mouse-buffer-menu' (normally
1153 ;; C-down-mouse-1).
1154 (defvar msb-mode-map
1155   (let ((map (make-sparse-keymap)))
1156     (mapcar (lambda (key)
1157               (define-key map key #'msb))
1158             (where-is-internal 'mouse-buffer-menu (make-sparse-keymap)))
1159     map))
1160
1161 ;;;###autoload
1162 (defun msb-mode (&optional arg)
1163   "Toggle Msb mode.
1164 With arg, turn Msb mode on if and only if arg is positive.
1165 This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
1166 different buffer menu using the function `msb'."
1167   (interactive "P")
1168   (setq msb-mode (if arg
1169                      (> (prefix-numeric-value arg) 0)
1170                    (not msb-mode)))
1171   (if msb-mode
1172       (progn
1173         (add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1174         (remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
1175     (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers)
1176     (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
1177   (run-hooks 'menu-bar-update-hook))
1178
1179 (add-to-list 'minor-mode-map-alist (cons 'msb-mode msb-mode-map))
1180
1181 (provide 'msb)
1182 (eval-after-load 'msb (run-hooks 'msb-after-load-hooks))
1183
1184 ;;; msb.el ends here