lisp/msb.el

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