lisp/msb.el

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