lisp/msb.el

   1 ;;; msb.el --- Customizable buffer-selection with multiple menus.
   2
   3 ;; Copyright (C) 1993, 1994, 1995 Lars Lindberg <Lars.Lindberg@sypro.cap.se>
   4
   5 ;; Author: Lars Lindberg <Lars.Lindberg@sypro.cap.se>
   6 ;; Created: 8 Oct 1993
   7 ;; Lindberg's last update version: 3.31
   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 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      4030
 168      "Manuals (%d)")
 169     ((eq major-mode 'w3-mode)
 170      4020
 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      4010
 183      "Mail (%d)")
 184     ;; Catchup for all non-file buffers
 185     ((and (not buffer-file-name)
 186           'no-multi)
 187      4099
 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 (defvar msb-separator-diff 100
 214   "*Non-nil means use separators.
 215 The separators will appear between all menus that have a sorting key that differs by this value or more.")
 216
 217 (defvar msb-files-by-directory-sort-key 0
 218   "*The sort key for files sorted by directory")
 219
 220 (defvar msb-max-menu-items 15
 221   "*The maximum number of items in a menu.
 222 If this variable is set to 15 for instance, then the submenu will be split up in minor parts, 15 items each.
 223 Nil means no limit.")
 224
 225 (defvar msb-max-file-menu-items 10
 226   "*The maximum number of items from different directories.
 227
 228 When the menu is of type `file by directory', this is the maximum
 229 number of buffers that are clumped together from different
 230 directories.
 231
 232 Set this to 1 if you want one menu per directory instead of clumping
 233 them together.
 234
 235 If the value is not a number, then the value 10 is used.")
 236
 237 (defvar msb-most-recently-used-sort-key -1010
 238   "*Where should the menu with the most recently used buffers be placed?")
 239
 240 (defvar msb-display-most-recently-used 15
 241   "*How many buffers should be in the most-recently-used menu.
 242  No buffers at all if less than 1 or nil (or any non-number).")
 243
 244 (defvar msb-most-recently-used-title "Most recently used (%d)"
 245   "*The title for the most-recently-used menu.")
 246
 247 (defvar msb-horizontal-shift-function '(lambda () 0)
 248   "*Function that specifies a number of pixels by which the top menu should
 249 be shifted leftwards.")
 250
 251 (defvar msb-display-invisible-buffers-p nil
 252   "*Show invisible buffers or not.
 253 Non-nil means that the buffer menu should include buffers that have
 254 names that starts with a space character.")
 255
 256 (defvar msb-item-handling-function 'msb-item-handler
 257   "*The appearance of a buffer menu.
 258
 259 The default function to call for handling the appearance of a menu
 260 item.  It should take to arguments, BUFFER and MAX-BUFFER-NAME-LENGTH,
 261 where the latter is the max length of all buffer names.
 262
 263 The function should return the string to use in the menu.
 264
 265 When the function is called, BUFFER is the current buffer.
 266 This function is called for items in the variable `msb-menu-cond' that
 267 have nil as ITEM-HANDLING-FUNCTION.  See `msb-menu-cond' for more
 268 information.")
 269
 270 (defvar msb-item-sort-function 'msb-sort-by-name
 271   "*The order of items in a buffer menu.
 272 The default function to call for handling the order of items in a menu
 273 item.  This function is called like a sort function.  The items
 274 look like (ITEM-NAME . BUFFER).
 275 ITEM-NAME is the name of the item that will appear in the menu.
 276 BUFFER is the buffer, this is not necessarily the current buffer.
 277
 278 Set this to nil or t if you don't want any sorting (faster).")
 279
 280 (defvar msb-files-by-directory nil
 281   "*Non-nil means that files should be sorted by directory instead of
 282 the groups in msb-menu-cond.")
 283
 284 (defvar msb-menu-cond msb--very-many-menus
 285   "*List of criteria for splitting the mouse buffer menu.
 286 The elements in the list should be of this type:
 287  (CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLING-FN ITEM-SORT-FN).
 288
 289 When making the split, the buffers are tested one by one against the
 290 CONDITION, just like a lisp cond: When hitting a true condition, the
 291 other criteria are *not* tested and the buffer name will appear in
 292 the menu with the menu-title corresponding to the true condition.
 293
 294 If the condition returns the symbol `multi', then the buffer will be
 295 added to this menu *and* tested for other menus too.  If it returns
 296 `no-multi', then the buffer will only be added if it hasn't been added
 297 to any other menu.
 298
 299 During this test, the buffer in question is the current buffer, and
 300 the test is surrounded by calls to `save-excursion' and
 301 `save-match-data'.
 302
 303 The categories are sorted by MENU-SORT-KEY.  Smaller keys are on
 304 top.  nil means don't display this menu.
 305
 306 MENU-TITLE is really a format.  If you add %d in it, the %d is replaced
 307 with the number of items in that menu.
 308
 309 ITEM-HANDLING-FN, is optional.  If it is supplied and is a
 310 function, than it is used for displaying the items in that particular
 311 buffer menu, otherwise the function pointed out by
 312 `msb-item-handling-function' is used.
 313
 314 ITEM-SORT-FN, is also optional.
 315 If it is not supplied, the function pointed out by
 316 `msb-item-sort-function' is used.
 317 If it is nil, then no sort takes place and the buffers are presented
 318 in least-recently-used order.
 319 If it is t, then no sort takes place and the buffers are presented in
 320 most-recently-used order.
 321 If it is supplied and non-nil and not t than it is used for sorting
 322 the items in that particular buffer menu.
 323
 324 Note1: There should always be a `catch-all' as last element,
 325 in this list.  That is an element like (t TITLE ITEM-HANDLING-FUNCTION).
 326 Note2: A buffer menu appears only if it has at least one buffer in it.
 327 Note3: If you have a CONDITION that can't be evaluated you will get an
 328 error every time you do \\[msb].")
 329
 330 (defvar msb-after-load-hooks nil
 331   "Hooks to be run after the msb package has been loaded.")
 332
 333 ;;;
 334 ;;; Internal variables
 335 ;;;
 336
 337 ;; The last calculated menu.
 338 (defvar msb--last-buffer-menu nil)
 339
 340 ;; If this is non-nil, then it is a string that describes the error.
 341 (defvar msb--error nil)
 342
 343 ;;;
 344 ;;; Some example function to be used for `msb-item-handling-function'.
 345 ;;;
 346 (defun msb-item-handler (buffer &optional maxbuf)
 347   "Create one string item, concerning BUFFER, for the buffer menu.
 348 The item looks like:
 349 *% <buffer-name>
 350 The `*' appears only if the buffer is marked as modified.
 351 The `%' appears only if the buffer is read-only.
 352 Optional second argument MAXBUF is completely ignored."
 353   (let ((name (buffer-name))
 354         (modified (if (buffer-modified-p) "*" " "))
 355         (read-only (if buffer-read-only "%" " ")))
 356     (format "%s%s %s" modified read-only name)))
 357
 358
 359 (eval-when-compile (require 'dired))
 360
 361 ;; `dired' can be called with a list of the form (directory file1 file2 ...)
 362 ;; which causes `dired-directory' to be in the same form.
 363 (defun msb--dired-directory ()
 364   (cond ((stringp dired-directory)
 365          (abbreviate-file-name (expand-file-name dired-directory)))
 366         ((consp dired-directory)
 367          (abbreviate-file-name (expand-file-name (car dired-directory))))
 368         (t
 369          (error "Unknown type of `dired-directory' in buffer %s"
 370                 (buffer-name)))))
 371
 372 (defun msb-dired-item-handler (buffer &optional maxbuf)
 373   "Create one string item, concerning a dired BUFFER, for the buffer menu.
 374 The item looks like:
 375 *% <buffer-name>
 376 The `*' appears only if the buffer is marked as modified.
 377 The `%' appears only if the buffer is read-only.
 378 Optional second argument MAXBUF is completely ignored."
 379   (let ((name (msb--dired-directory))
 380         (modified (if (buffer-modified-p) "*" " "))
 381         (read-only (if buffer-read-only "%" " ")))
 382     (format "%s%s %s" modified read-only name)))
 383
 384 (defun msb-alon-item-handler (buffer maxbuf)
 385   "Create one string item for the buffer menu.
 386 The item looks like:
 387 <buffer-name> *%# <file-name>
 388 The `*' appears only if the buffer is marked as modified.
 389 The `%' appears only if the buffer is read-only.
 390 The `#' appears only version control file (SCCS/RCS)."
 391   (format (format "%%%ds  %%s%%s%%s  %%s" maxbuf)
 392           (buffer-name buffer)
 393           (if (buffer-modified-p) "*" " ")
 394           (if buffer-read-only "%" " ")
 395           (if (and (boundp 'vc-mode) vc-mode) "#" " ")
 396           (or buffer-file-name "")))
 397
 398 ;;;
 399 ;;; Some example function to be used for `msb-item-sort-function'.
 400 ;;;
 401 (defun msb-sort-by-name (item1 item2)
 402   "Sorts the items depending on their buffer-name
 403 An item look like (NAME . BUFFER)."
 404   (string-lessp (buffer-name (cdr item1))
 405                 (buffer-name (cdr item2))))
 406
 407
 408 (defun msb-sort-by-directory (item1 item2)
 409   "Sorts the items depending on their directory.  Made for dired.
 410 An item look like (NAME . BUFFER)."
 411   (string-lessp (save-excursion (set-buffer (cdr item1)) (msb--dired-directory))
 412                 (save-excursion (set-buffer (cdr item2)) (msb--dired-directory))))
 413
 414 ;;;
 415 ;;; msb
 416 ;;;
 417 ;;; This function can be used instead of (mouse-buffer-menu EVENT)
 418 ;;; function in "mouse.el".
 419 ;;;
 420 (defun msb (event)
 421   "Pop up several menus of buffers for selection with the mouse.
 422 This command switches buffers in the window that you clicked on, and
 423 selects that window.
 424
 425 See the function `mouse-select-buffer' and the variable
 426 `msb-menu-cond' for more information about how the menus are split."
 427   (interactive "e")
 428   (let ((old-window (selected-window))
 429         (window (posn-window (event-start event))))
 430     (unless (framep window) (select-window window))
 431     (let ((buffer (mouse-select-buffer event)))
 432       (if buffer
 433           (switch-to-buffer buffer)
 434         (select-window old-window))))
 435   nil)
 436
 437 ;;;
 438 ;;; Some supportive functions
 439 ;;;
 440 (defun msb-invisible-buffer-p (&optional buffer)
 441   "Return t if optional BUFFER is an \"invisible\" buffer.
 442 If the argument is left out or nil, then the current buffer is considered."
 443   (and (> (length (buffer-name buffer)) 0)
 444        (eq ?\ (aref (buffer-name buffer) 0))))
 445
 446 ;; Strip one hierarchy level from the end of PATH.
 447 (defun msb--strip-path (path)
 448   (save-match-data
 449     (if (string-match "\\(.+\\)/[^/]+$" path)
 450         (substring path (match-beginning 1) (match-end 1))
 451       "/")))
 452
 453 ;; Create an alist with all buffers from LIST that lies under the same
 454 ;; directory will be in the same item as the directory string as
 455 ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K BUFFER-K+1...)) ...)
 456 (defun msb--init-file-alist (list)
 457   (let ((buffer-alist
 458          (sort (mapcan
 459                 (function
 460                  (lambda (buffer)
 461                    (let ((file-name (buffer-file-name buffer)))
 462                      (when file-name
 463                        (list (cons (msb--strip-path file-name) buffer))))))
 464                 list)
 465                (function (lambda (item1 item2)
 466                            (string< (car item1) (car item2)))))))
 467     ;; Make alist that looks like
 468     ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K)) ...)
 469     (let ((path nil)
 470           (buffers nil)
 471           (result nil))
 472       (append
 473        (mapcan (function
 474                (lambda (item)
 475                  (cond
 476                   ((and path
 477                         (string= path (car item)))
 478                    (push (cdr item) buffers)
 479                    nil)
 480                   (t
 481                    (when path
 482                      (setq result (cons path buffers)))
 483                    (setq path (car item))
 484                    (setq buffers (list (cdr item)))
 485                    (and result (list result))))))
 486               buffer-alist)
 487        (list (cons path buffers))))))
 488
 489 ;; Choose file-menu with respect to directory for every buffer in LIST.
 490 (defun msb--choose-file-menu (list)
 491   (let ((buffer-alist (msb--init-file-alist list))
 492         (final-list nil)
 493         (max-clumped-together (if (numberp msb-max-file-menu-items)
 494                                   msb-max-file-menu-items
 495                                 10))
 496         (top-found-p nil)
 497         (last-path nil)
 498         first rest path buffers)
 499     (setq first (car buffer-alist))
 500     (setq rest (cdr buffer-alist))
 501     (setq path (car first))
 502     (setq buffers (cdr first))
 503     (while rest
 504       (let ((found-p nil)
 505             (tmp-rest rest)
 506             new-path item)
 507         (setq item (car tmp-rest))
 508         (while (and tmp-rest
 509                     (<= (length buffers) max-clumped-together)
 510                     (>= (length (car item)) (length path))
 511                     (string= path (substring (car item) 0 (length path))))
 512           (setq found-p t)
 513           (setq buffers (append buffers (cdr item)))
 514           (setq tmp-rest (cdr tmp-rest))
 515           (setq item (car tmp-rest)))
 516         (cond
 517          ((> (length buffers) max-clumped-together)
 518           (setq last-path (car first))
 519           (setq first
 520                 (cons (format (if top-found-p
 521                                   "%s/... (%d)"
 522                                 "%s (%d)")
 523                               (car first)
 524                               (length (cdr first)))
 525                       (cdr first)))
 526           (setq top-found-p nil)
 527           (push first final-list)
 528           (setq first (car rest)
 529                 rest (cdr rest))
 530           (setq path (car first)
 531                 buffers (cdr first)))
 532          (t
 533           (when found-p
 534             (setq top-found-p t)
 535             (setq first (cons path buffers)
 536                   rest tmp-rest))
 537           (setq path (msb--strip-path path)
 538                 buffers (cdr first))
 539           (when (and last-path
 540                      (or (and (>= (length path) (length last-path))
 541                               (string= last-path
 542                                        (substring path 0 (length last-path))))
 543                          (and (< (length path) (length last-path))
 544                               (string= path
 545                                        (substring last-path 0 (length path))))))
 546
 547             (setq first
 548                   (cons (format (if top-found-p
 549                                     "%s/... (%d)"
 550                                   "%s (%d)")
 551                                 (car first)
 552                                 (length (cdr first)))
 553                         (cdr first)))
 554             (setq top-found-p nil)
 555             (push first final-list)
 556             (setq first (car rest)
 557                   rest (cdr rest))
 558             (setq path (car first)
 559                 buffers (cdr first)))))))
 560     (setq first
 561           (cons (format (if top-found-p
 562                             "%s/... (%d)"
 563                           "%s (%d)")
 564                         (car first)
 565                         (length (cdr first)))
 566                 (cdr first)))
 567     (setq top-found-p nil)
 568     (push first final-list)
 569     (nreverse final-list)))
 570
 571 ;; Create a vector as:
 572 ;; [BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER)
 573 ;; from an element in `msb-menu-cond'.  See that variable for a
 574 ;; description of its elements.
 575 (defun msb--create-function-info (menu-cond-elt)
 576   (let* ((list-symbol (make-symbol "-msb-buffer-list"))
 577          (tmp-ih (and (> (length menu-cond-elt) 3)
 578                       (nth 3 menu-cond-elt)))
 579          (item-handler (if (and tmp-ih (fboundp tmp-ih))
 580                            tmp-ih
 581                          msb-item-handling-function))
 582          (tmp-s (if (> (length menu-cond-elt) 4)
 583                     (nth 4 menu-cond-elt)
 584                   msb-item-sort-function))
 585          (sorter (if (or (fboundp tmp-s)
 586                          (null tmp-s)
 587                          (eq tmp-s t))
 588                     tmp-s
 589                    msb-item-sort-function)))
 590     (when (< (length menu-cond-elt) 3)
 591       (error "Wrong format of msb-menu-cond."))
 592     (when (and (> (length menu-cond-elt) 3)
 593                (not (fboundp tmp-ih)))
 594       (signal 'invalid-function (list tmp-ih)))
 595     (when (and (> (length menu-cond-elt) 4)
 596                tmp-s
 597                (not (fboundp tmp-s))
 598                (not (eq tmp-s t)))
 599       (signal 'invalid-function (list tmp-s)))
 600     (set list-symbol ())
 601     (vector list-symbol                 ;BUFFER-LIST-VARIABLE
 602             (nth 0 menu-cond-elt)       ;CONDITION
 603             (nth 1 menu-cond-elt)       ;SORT-KEY
 604             (nth 2 menu-cond-elt)       ;MENU-TITLE
 605             item-handler                ;ITEM-HANDLER
 606             sorter)                     ;SORTER
 607     ))
 608
 609 ;; This defsubst is only used in `msb--choose-menu' below.  It was
 610 ;; pulled out merely to make the code somewhat clearer.  The indention
 611 ;; level was too big.
 612 (defsubst msb--collect (function-info-vector)
 613   (let ((result nil)
 614         (multi-flag nil)
 615         function-info-list)
 616     (setq function-info-list
 617           (loop for fi
 618                 across function-info-vector
 619                 if (and (setq result
 620                               (eval (aref fi 1))) ;Test CONDITION
 621                         (not (and (eq result 'no-multi)
 622                                   multi-flag))
 623                         (progn (when (eq result 'multi)
 624                                  (setq multi-flag t))
 625                                t))
 626                 collect fi
 627                 until (and result
 628                            (not (eq result 'multi)))))
 629     (when (and (not function-info-list)
 630                (not result))
 631       (error "No catch-all in msb-menu-cond!"))
 632     function-info-list))
 633
 634 ;; Adds BUFFER to the menu depicted by FUNCTION-INFO
 635 ;; All side-effects.  Adds an element of form (BUFFER-TITLE . BUFFER)
 636 ;; to the buffer-list variable in function-info.
 637 (defun msb--add-to-menu (buffer function-info max-buffer-name-length)
 638   (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
 639     ;; Here comes the hairy side-effect!
 640     (set list-symbol
 641          (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
 642                               buffer
 643                               max-buffer-name-length)
 644                      buffer)
 645                (eval list-symbol)))))
 646
 647 ;; Selects the appropriate menu for BUFFER.
 648 ;; This is all side-effects, folks!
 649 ;; This should be optimized.
 650 (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
 651   (unless (and (not msb-display-invisible-buffers-p)
 652                (msb-invisible-buffer-p buffer))
 653     (condition-case nil
 654         (save-excursion
 655           (set-buffer buffer)
 656           ;; Menu found.  Add to this menu
 657           (mapc (function
 658                  (lambda (function-info)
 659                    (msb--add-to-menu buffer function-info max-buffer-name-length)))
 660                 (msb--collect function-info-vector)))
 661       (error (unless msb--error
 662                (setq msb--error
 663                      (format
 664                       "In msb-menu-cond, error for buffer `%s'."
 665                       (buffer-name buffer)))
 666                (error msb--error))))))
 667
 668 ;; Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the
 669 ;; buffer-list is empty.
 670 (defun msb--create-sort-item (function-info)
 671   (let ((buffer-list (eval (aref function-info 0))))
 672     (when buffer-list
 673       (let ((sorter (aref function-info 5)) ;SORTER
 674             (sort-key (aref function-info 2))) ;MENU-SORT-KEY
 675         (when sort-key
 676           (cons sort-key
 677                 (cons (format (aref function-info 3) ;MENU-TITLE
 678                               (length buffer-list))
 679                       (cond
 680                        ((null sorter)
 681                         buffer-list)
 682                        ((eq sorter t)
 683                         (nreverse buffer-list))
 684                        (t
 685                         (sort buffer-list sorter))))))))))
 686
 687 ;; Returns a list on the form ((TITLE . BUFFER-LIST)) for
 688 ;; the most recently used buffers.
 689 (defun msb--most-recently-used-menu (max-buffer-name-length)
 690   (when (and (numberp msb-display-most-recently-used)
 691              (> msb-display-most-recently-used 0))
 692     (let* ((buffers (cdr (buffer-list)))
 693            (most-recently-used
 694             (loop with n = 0
 695                   for buffer in buffers
 696                   if (save-excursion
 697                        (set-buffer buffer)
 698                        (and (not (msb-invisible-buffer-p))
 699                             (not (eq major-mode 'dired-mode))))
 700                   collect (save-excursion
 701                             (set-buffer buffer)
 702                             (cons (funcall msb-item-handling-function
 703                                            buffer
 704                                            max-buffer-name-length)
 705                                   buffer))
 706                   and do (incf n)
 707                   until (>= n msb-display-most-recently-used))))
 708       (cons (if (stringp msb-most-recently-used-title)
 709                 (format msb-most-recently-used-title
 710                         (length most-recently-used))
 711               (signal 'wrong-type-argument (list msb-most-recently-used-title)))
 712             most-recently-used))))
 713
 714 (defun msb--create-buffer-menu-2 ()
 715   (let ((max-buffer-name-length 0)
 716         file-buffers
 717         function-info-vector)
 718     ;; Calculate the longest buffer name.
 719     (mapc
 720      (function
 721       (lambda (buffer)
 722         (if (or msb-display-invisible-buffers-p
 723                 (not (msb-invisible-buffer-p)))
 724             (setq max-buffer-name-length
 725                   (max max-buffer-name-length
 726                        (length (buffer-name buffer)))))))
 727      (buffer-list))
 728     ;; Make a list with elements of type
 729     ;; (BUFFER-LIST-VARIABLE
 730     ;;  CONDITION
 731     ;;  MENU-SORT-KEY
 732     ;;  MENU-TITLE
 733     ;;  ITEM-HANDLER
 734     ;;  SORTER)
 735     ;; Uses "function-global" variables:
 736     ;; function-info-vector
 737     (setq function-info-vector
 738           (apply (function vector)
 739                  (mapcar (function msb--create-function-info)
 740                          msb-menu-cond)))
 741     ;; Split the buffer-list into several lists; one list for each
 742     ;; criteria.  This is the most critical part with respect to time.
 743     (mapc (function (lambda (buffer)
 744                       (cond ((and msb-files-by-directory
 745                                   (buffer-file-name buffer))
 746                              (push buffer file-buffers))
 747                             (t
 748                              (msb--choose-menu buffer
 749                                                function-info-vector
 750                                                max-buffer-name-length)))))
 751           (buffer-list))
 752     (when file-buffers
 753       (setq file-buffers
 754             (mapcar (function
 755                      (lambda (buffer-list)
 756                        (cons msb-files-by-directory-sort-key
 757                              (cons (car buffer-list)
 758                                    (sort
 759                                     (mapcar (function
 760                                              (lambda (buffer)
 761                                                (cons (save-excursion
 762                                                        (set-buffer buffer)
 763                                                        (funcall msb-item-handling-function
 764                                                               buffer
 765                                                               max-buffer-name-length))
 766                                                      buffer)))
 767                                             (cdr buffer-list))
 768                                     (function
 769                                      (lambda (item1 item2)
 770                                        (string< (car item1) (car item2)))))))))
 771                      (msb--choose-file-menu file-buffers))))
 772     ;; Now make the menu - a list of (TITLE . BUFFER-LIST)
 773     (let* (menu
 774            (most-recently-used
 775             (msb--most-recently-used-menu max-buffer-name-length))
 776            (others (append file-buffers
 777                            (loop for elt
 778                                  across function-info-vector
 779                                  for value = (msb--create-sort-item elt)
 780                                  if value collect value))))
 781       (setq menu
 782             (mapcar 'cdr                ;Remove the SORT-KEY
 783                     ;; Sort the menus - not the items.
 784                     (msb--add-separators
 785                     (sort
 786                      ;; Get a list of (SORT-KEY TITLE . BUFFER-LIST)
 787                      ;; Also sorts the items within the menus.
 788                      (if (cdr most-recently-used)
 789                          (cons
 790                           ;; Add most recent used buffers
 791                           (cons msb-most-recently-used-sort-key
 792                                 most-recently-used)
 793                           others)
 794                        others)
 795                      (function (lambda (elt1 elt2)
 796                                  (< (car elt1) (car elt2))))))))
 797       ;; Now make it a keymap menu
 798       (append
 799        '(keymap "Select Buffer")
 800        (msb--make-keymap-menu menu)
 801        (when msb-separator-diff
 802          (list (list 'separator "---")))
 803        (list (cons 'toggle
 804                    (cons
 805                    (if msb-files-by-directory
 806                        "*Files by type*"
 807                      "*Files by directory*")
 808                    'msb--toggle-menu-type)))))))
 809
 810 (defun msb--create-buffer-menu  ()
 811   (save-match-data
 812     (save-excursion
 813       (msb--create-buffer-menu-2))))
 814
 815 ;;;
 816 ;;; Multi purpose function for selecting a buffer with the mouse.
 817 ;;;
 818 (defun msb--toggle-menu-type ()
 819   (interactive)
 820   (setq msb-files-by-directory (not msb-files-by-directory))
 821   (menu-bar-update-buffers t))
 822
 823 (defun mouse-select-buffer (event)
 824   "Pop up several menus of buffers, for selection with the mouse.
 825 Returns the selected buffer or nil if no buffer is selected.
 826
 827 The way the buffers are split is conveniently handled with the
 828 variable `msb-menu-cond'."
 829   ;; Popup the menu and return the selected buffer.
 830   (when (or msb--error
 831             (not msb--last-buffer-menu)
 832             (not (fboundp 'frame-or-buffer-changed-p))
 833             (frame-or-buffer-changed-p))
 834     (setq msb--error nil)
 835     (setq msb--last-buffer-menu (msb--create-buffer-menu)))
 836   (let ((position event)
 837         choice)
 838     (when (and (fboundp 'posn-x-y)
 839                (fboundp 'posn-window))
 840       (let ((posX (car (posn-x-y (event-start event))))
 841             (posY (cdr (posn-x-y (event-start event))))
 842             (posWind (posn-window (event-start event))))
 843         ;; adjust position
 844         (setq posX (- posX (funcall msb-horizontal-shift-function))
 845               position (list (list posX posY) posWind))))
 846     ;; This `sit-for' magically makes the menu stay up if the mouse
 847     ;; button is released within 0.1 second.
 848     (sit-for 0 100)
 849     ;; Popup the menu
 850     (setq choice (x-popup-menu position msb--last-buffer-menu))
 851     (cond
 852      ((eq (car choice) 'toggle)
 853       ;; Bring up the menu again with type toggled.
 854       (msb--toggle-menu-type)
 855       (mouse-select-buffer event))
 856      ((and (numberp (car choice))
 857            (null (cdr choice)))
 858       (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice) msb--last-buffer-menu))))
 859         (mouse-select-buffer event)))
 860      ((while (numberp (car choice))
 861         (setq choice (cdr choice))))
 862      ((and (stringp (car choice))
 863            (null (cdr choice)))
 864       (car choice))
 865      ((null choice)
 866       choice)
 867      (t
 868       (error "Unknown form for buffer: %s" choice)))))
 869
 870 ;; Add separators
 871 (defun msb--add-separators (sorted-list)
 872   (cond
 873    ((or (not msb-separator-diff)
 874         (not (numberp msb-separator-diff)))
 875     sorted-list)
 876    (t
 877     (let ((last-key nil))
 878       (mapcan
 879        (function
 880         (lambda (item)
 881           (cond
 882            ((and msb-separator-diff
 883                  last-key
 884                  (> (- (car item) last-key)
 885                     msb-separator-diff))
 886             (setq last-key (car item))
 887             (list (cons last-key 'separator)
 888                   item))
 889            (t
 890             (setq last-key (car item))
 891             (list item)))))
 892        sorted-list)))))
 893
 894 (defun msb--split-menus-2 (list mcount result)
 895   (cond
 896    ((> (length list) msb-max-menu-items)
 897     (let ((count 0)
 898           sub-name
 899           (tmp-list nil))
 900       (while (< count msb-max-menu-items)
 901         (push (pop list) tmp-list)
 902         (incf count))
 903     (setq tmp-list (nreverse tmp-list))
 904     (setq sub-name (concat (car (car tmp-list)) "..."))
 905     (push (append (list mcount sub-name
 906                         'keymap sub-name)
 907                   tmp-list)
 908           result))
 909     (msb--split-menus-2 list (1+ mcount) result))
 910    ((null result)
 911     list)
 912    (t
 913     (let (sub-name)
 914       (setq sub-name (concat (car (car list)) "..."))
 915       (push (append (list mcount sub-name
 916                         'keymap sub-name)
 917                   list)
 918           result))
 919     (nreverse result))))
 920
 921 (defun msb--split-menus (list)
 922  (msb--split-menus-2 list 0 nil))
 923
 924
 925 (defun msb--make-keymap-menu (raw-menu)
 926   (let ((end (cons '(nil) 'menu-bar-select-buffer))
 927         (mcount 0))
 928     (mapcar
 929      (function
 930       (lambda (sub-menu)
 931         (cond
 932          ((eq 'separator sub-menu)
 933           (list 'separator "---"))
 934          (t
 935           (let ((buffers (mapcar (function
 936                                   (lambda (item)
 937                                     (let ((string (car item))
 938                                           (buffer (cdr item)))
 939                                       (cons (buffer-name buffer)
 940                                             (cons string end)))))
 941                                  (cdr sub-menu))))
 942             (append (list (incf mcount) (car sub-menu)
 943                           'keymap (car sub-menu))
 944                     (msb--split-menus buffers)))))))
 945      raw-menu)))
 946
 947 (defun menu-bar-update-buffers (&optional arg)
 948   ;; If user discards the Buffers item, play along.
 949   (when (and (lookup-key (current-global-map) [menu-bar buffer])
 950              (or (not (fboundp 'frame-or-buffer-changed-p))
 951                  (frame-or-buffer-changed-p)
 952                  arg))
 953     (let ((frames (frame-list))
 954           buffers-menu frames-menu)
 955       ;; Make the menu of buffers proper.
 956       (setq msb--last-buffer-menu (msb--create-buffer-menu))
 957       (setq buffers-menu msb--last-buffer-menu)
 958       ;; Make a Frames menu if we have more than one frame.
 959       (when (cdr frames)
 960         (let* ((frame-length (length frames))
 961                (f-title  (format "Frames (%d)" frame-length)))
 962           ;; List only the N most recently selected frames
 963           (when (and (integerp msb-max-menu-items)
 964                      (>  msb-max-menu-items 1)
 965                      (> frame-length msb-max-menu-items))
 966             (setcdr (nthcdr msb-max-menu-items frames) nil))
 967           (setq frames-menu
 968                 (nconc
 969                  (list 'frame f-title '(nil) 'keymap f-title)
 970                  (mapcar
 971                   (function
 972                    (lambda (frame)
 973                      (nconc
 974                       (list frame
 975                             (cdr (assq 'name
 976                                        (frame-parameters frame)))
 977                             (cons nil nil))
 978                       'menu-bar-select-frame)))
 979                   frames)))))
 980       (define-key (current-global-map) [menu-bar buffer]
 981         (cons "Buffers"
 982               (if (and buffers-menu frames-menu)
 983                   ;; Combine Frame and Buffers menus with separator between
 984                   (nconc (list 'keymap "Buffers and Frames" frames-menu
 985                                (and msb-separator-diff '(separator "---")))
 986                          (cddr buffers-menu))
 987                 (or buffers-menu 'undefined)))))))
 988
 989 (when (and (boundp 'menu-bar-update-hook)
 990            (not (fboundp 'frame-or-buffer-changed-p)))
 991   (defvar msb--buffer-count 0)
 992   (defun frame-or-buffer-changed-p ()
 993     (let ((count (length (buffer-list))))
 994       (when (/= count msb--buffer-count)
 995         (setq msb--buffer-count count)
 996         t))))
 997
 998 (unless (or (not (boundp 'menu-bar-update-hook))
 999             (memq 'menu-bar-update-buffers menu-bar-update-hook))
1000     (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
1001
1002 (and (fboundp 'mouse-buffer-menu)
1003      (substitute-key-definition 'mouse-buffer-menu 'msb (current-global-map)))
1004
1005 (provide 'msb)
1006 (eval-after-load 'msb (run-hooks 'msb-after-load-hooks))
1007 ;;; msb.el ends here