lisp/msb.el

   1 ;;; msb.el --- Customizable buffer-selection with multiple menus.
   2 ;; Copyright (C) 1993, 1994 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.27
   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 ;;   (require 'msb)
  32 ;;   Note! You now use msb instead of mouse-buffer-menu.
  33 ;;
  34 ;;   Now try the menu bar Buffers menu.
  35 ;;
  36 ;; Customization:
  37 ;;   Look at the variable `msb-menu-cond' for deciding what menus you
  38 ;;   want.  It's not that hard to customize, despite my not-so-good
  39 ;;   doc-string.  Feel free to send me a better doc-string.
  40 ;;   There are some constants for you to try here:
  41 ;;   msb--few-menus
  42 ;;   msb--very-many-menus (default)
  43 ;;
  44 ;;   Look at the variable `msb-item-handling-function' for customization
  45 ;;   of the appearance of every menu item.  Try for instance setting
  46 ;;   it to `msb-alon-item-handler'.
  47 ;;
  48 ;;   Look at the variable `msb-item-sort-function' for customization
  49 ;;   of sorting the menus.  Set it to t for instance, which means no
  50 ;;   sorting - you will get latest used buffer first.
  51 ;;
  52 ;;   Also check out the variable `msb-display-invisible-buffers-p'.
  53
  54 ;; Known bugs:
  55 ;; - Files-by-directory
  56 ;;   + No possibility to show client/changed buffers separately
  57 ;; Future enhancements:
  58 ;; - [Mattes] had a suggestion about sorting files by extension.
  59 ;;   I (Lars Lindberg) think this case could be solved if msb.el was
  60 ;;   rewritten to handle more dynamic splitting.  It's now completely
  61 ;;   static, depending on the menu-cond.  If the splitting could also
  62 ;;   be done by a user-defined function a lot of cases would be
  63 ;;   solved.
  64 ;; - [Jim] suggested that the Frame menu became a part of the buffer menu.
  65
  66 ;;; Thanks goes to
  67 ;;  [msb] - Mark Brader <msb@sq.com>
  68 ;;  [Chalupsky] - Hans Chalupsky <hans@cs.Buffalo.EDU>
  69 ;;  [jim] - Jim Berry <m1jhb00@FRB.GOV>
  70 ;;  [larry] - Larry Rosenberg <ljr@ictv.com>
  71 ;;  [will] - Will Henney <will@astroscu.unam.mx>
  72 ;;  [jaalto] - Jari Aalto <jaalto@tre.tele.nokia.fi>
  73 ;;  [kifer] - Michael Kifer <kifer@sbkifer.cs.sunysb.edu>
  74 ;;  [Gael] - Gael Marziou <gael@gnlab030.grenoble.hp.com>
  75 ;;  [Gillespie] - Dave Gillespie <daveg@thymus.synaptics.com>
  76 ;;  [Alon] - Alon Albert <alon@milcse.rtsg.mot.com>
  77 ;;  [KevinB] - Kevin Broadey, <KevinB@bartley.demon.co.uk>
  78 ;;  [Ake] - Ake Stenhof <ake@cadpoint.se>
  79 ;;  [RMS] - Richard Stallman <rms@gnu.ai.mit.edu>
  80 ;;  [Fisk] - 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 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 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 ((buffer (mouse-select-buffer event))
 425         (window (posn-window (event-start event))))
 426     (when buffer
 427       (unless (framep window) (select-window window))
 428       (switch-to-buffer buffer)))
 429   nil)
 430
 431 ;;;
 432 ;;; Some supportive functions
 433 ;;;
 434 (defun msb-invisible-buffer-p (&optional buffer)
 435   "Return t if optional BUFFER is an \"invisible\" buffer.
 436 If the argument is left out or nil, then the current buffer is considered."
 437   (and (> (length (buffer-name buffer)) 0)
 438        (eq ?\ (aref (buffer-name buffer) 0))))
 439
 440 ;; Strip one hierarcy level from the end of PATH.
 441 (defun msb--strip-path (path)
 442   (save-match-data
 443     (if (string-match "\\(.+\\)/[^/]+$" path)
 444         (substring path (match-beginning 1) (match-end 1))
 445       "/")))
 446
 447 ;; Create an alist with all buffers from LIST that lies under the same
 448 ;; directory will be in the same item as the directory string as
 449 ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K BUFFER-K+1...)) ...)
 450 (defun msb--init-file-alist (list)
 451   (let ((buffer-alist
 452          (sort (mapcan
 453                 (function
 454                  (lambda (buffer)
 455                    (let ((file-name (buffer-file-name buffer)))
 456                      (when file-name
 457                        (list (cons (msb--strip-path file-name) buffer))))))
 458                 list)
 459                (function (lambda (item1 item2)
 460                            (string< (car item1) (car item2)))))))
 461     ;; Make alist that looks like
 462     ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K)) ...)
 463     (let ((path nil)
 464           (buffers nil)
 465           (result nil))
 466       (append
 467        (mapcan (function
 468                (lambda (item)
 469                  (cond
 470                   ((and path
 471                         (string= path (car item)))
 472                    (push (cdr item) buffers)
 473                    nil)
 474                   (t
 475                    (when path
 476                      (setq result (cons path buffers)))
 477                    (setq path (car item))
 478                    (setq buffers (list (cdr item)))
 479                    (and result (list result))))))
 480               buffer-alist)
 481        (list (cons path buffers))))))
 482
 483 ;; Choose file-menu with respect to directory for every buffer in LIST.
 484 (defun msb--choose-file-menu (list)
 485   (let ((buffer-alist (msb--init-file-alist list))
 486         (final-list nil)
 487         (max-clumped-together (if (numberp msb-max-file-menu-items)
 488                                   msb-max-file-menu-items
 489                                 10))
 490         (top-found-p nil)
 491         (last-path nil)
 492         first rest path buffers)
 493     (setq first (car buffer-alist))
 494     (setq rest (cdr buffer-alist))
 495     (setq path (car first))
 496     (setq buffers (cdr first))
 497     (while rest
 498       (let ((found-p nil)
 499             (tmp-rest rest)
 500             new-path item)
 501         (setq item (car tmp-rest))
 502         (while (and tmp-rest
 503                     (<= (length buffers) max-clumped-together)
 504                     (>= (length (car item)) (length path))
 505                     (string= path (substring (car item) 0 (length path))))
 506           (setq found-p t)
 507           (setq buffers (append buffers (cdr item)))
 508           (setq tmp-rest (cdr tmp-rest))
 509           (setq item (car tmp-rest)))
 510         (cond
 511          ((> (length buffers) max-clumped-together)
 512           (setq last-path (car first))
 513           (setq first
 514                 (cons (format (if top-found-p
 515                                   "%s/... (%d)"
 516                                 "%s (%d)")
 517                               (car first)
 518                               (length (cdr first)))
 519                       (cdr first)))
 520           (setq top-found-p nil)
 521           (push first final-list)
 522           (setq first (car rest)
 523                 rest (cdr rest))
 524           (setq path (car first)
 525                 buffers (cdr first)))
 526          (t
 527           (when found-p
 528             (setq top-found-p t)
 529             (setq first (cons path buffers)
 530                   rest tmp-rest))
 531           (setq path (msb--strip-path path)
 532                 buffers (cdr first))
 533           (when (and last-path
 534                      (or (and (>= (length path) (length last-path))
 535                               (string= last-path
 536                                        (substring path 0 (length last-path))))
 537                          (and (< (length path) (length last-path))
 538                               (string= path
 539                                        (substring last-path 0 (length path))))))
 540
 541             (setq first
 542                   (cons (format (if top-found-p
 543                                     "%s/... (%d)"
 544                                   "%s (%d)")
 545                                 (car first)
 546                                 (length (cdr first)))
 547                         (cdr first)))
 548             (setq top-found-p nil)
 549             (push first final-list)
 550             (setq first (car rest)
 551                   rest (cdr rest))
 552             (setq path (car first)
 553                 buffers (cdr first)))))))
 554     (setq first
 555           (cons (format (if top-found-p
 556                             "%s/... (%d)"
 557                           "%s (%d)")
 558                         (car first)
 559                         (length (cdr first)))
 560                 (cdr first)))
 561     (setq top-found-p nil)
 562     (push first final-list)
 563     (nreverse final-list)))
 564
 565 ;; Create a vector as:
 566 ;; [BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER)
 567 ;; from an element in `msb-menu-cond'.  See that variable for a
 568 ;; description of its elements.
 569 (defun msb--create-function-info (menu-cond-elt)
 570   (let* ((list-symbol (make-symbol "-msb-buffer-list"))
 571          (tmp-ih (and (> (length menu-cond-elt) 3)
 572                       (nth 3 menu-cond-elt)))
 573          (item-handler (if (and tmp-ih (fboundp tmp-ih))
 574                            tmp-ih
 575                          msb-item-handling-function))
 576          (tmp-s (if (> (length menu-cond-elt) 4)
 577                     (nth 4 menu-cond-elt)
 578                   msb-item-sort-function))
 579          (sorter (if (or (fboundp tmp-s)
 580                          (null tmp-s)
 581                          (eq tmp-s t))
 582                     tmp-s
 583                    msb-item-sort-function)))
 584     (when (< (length menu-cond-elt) 3)
 585       (error "Wrong format of msb-menu-cond."))
 586     (when (and (> (length menu-cond-elt) 3)
 587                (not (fboundp tmp-ih)))
 588       (signal 'invalid-function (list tmp-ih)))
 589     (when (and (> (length menu-cond-elt) 4)
 590                tmp-s
 591                (not (fboundp tmp-s))
 592                (not (eq tmp-s t)))
 593       (signal 'invalid-function (list tmp-s)))
 594     (set list-symbol ())
 595     (vector list-symbol                 ;BUFFER-LIST-VARIABLE
 596             (nth 0 menu-cond-elt)       ;CONDITION
 597             (nth 1 menu-cond-elt)       ;SORT-KEY
 598             (nth 2 menu-cond-elt)       ;MENU-TITLE
 599             item-handler                ;ITEM-HANDLER
 600             sorter)                     ;SORTER
 601     ))
 602
 603 ;; This defsubst is only used in `msb--choose-menu' below.  It was
 604 ;; pulled out merely to make the code somewhat clearer.  The indention
 605 ;; level was too big.
 606 (defsubst msb--collect (function-info-vector)
 607   (let ((result nil)
 608         (multi-flag nil)
 609         function-info-list)
 610     (setq function-info-list
 611           (loop for fi
 612                 across function-info-vector
 613                 if (and (setq result
 614                               (eval (aref fi 1))) ;Test CONDITION
 615                         (not (and (eq result 'no-multi)
 616                                   multi-flag))
 617                         (progn (when (eq result 'multi)
 618                                  (setq multi-flag t))
 619                                t))
 620                 collect fi
 621                 until (and result
 622                            (not (eq result 'multi)))))
 623     (when (and (not function-info-list)
 624                (not result))
 625       (error "No catch-all in msb-menu-cond!"))
 626     function-info-list))
 627
 628 ;; Adds BUFFER to the menu depicted by FUNCTION-INFO
 629 ;; All side-effects.  Adds an element of form (BUFFER-TITLE . BUFFER)
 630 ;; to the buffer-list variable in function-info.
 631 (defun msb--add-to-menu (buffer function-info max-buffer-name-length)
 632   (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE
 633     ;; Here comes the hairy side-effect!
 634     (set list-symbol
 635          (cons (cons (funcall (aref function-info 4) ;ITEM-HANDLER
 636                               buffer
 637                               max-buffer-name-length)
 638                      buffer)
 639                (eval list-symbol)))))
 640
 641 ;; Selects the appropriate menu for BUFFER.
 642 ;; This is all side-effects, folks!
 643 ;; This should be optimized.
 644 (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
 645   (unless (and (not msb-display-invisible-buffers-p)
 646                (msb-invisible-buffer-p buffer))
 647     (condition-case nil
 648         (save-excursion
 649           (set-buffer buffer)
 650           ;; Menu found.  Add to this menu
 651           (mapc (function
 652                  (lambda (function-info)
 653                    (msb--add-to-menu buffer function-info max-buffer-name-length)))
 654                 (msb--collect function-info-vector)))
 655       (error (unless msb--error
 656                (setq msb--error
 657                      (format
 658                       "In msb-menu-cond, error for buffer `%s'."
 659                       (buffer-name buffer)))
 660                (error msb--error))))))
 661
 662 ;; Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the
 663 ;; buffer-list is empty.
 664 (defun msb--create-sort-item (function-info)
 665   (let ((buffer-list (eval (aref function-info 0))))
 666     (when buffer-list
 667       (let ((sorter (aref function-info 5)) ;SORTER
 668             (sort-key (aref function-info 2))) ;MENU-SORT-KEY
 669         (when sort-key
 670           (cons sort-key
 671                 (cons (format (aref function-info 3) ;MENU-TITLE
 672                               (length buffer-list))
 673                       (cond
 674                        ((null sorter)
 675                         buffer-list)
 676                        ((eq sorter t)
 677                         (nreverse buffer-list))
 678                        (t
 679                         (sort buffer-list sorter))))))))))
 680
 681 ;; Returns a list on the form ((TITLE . BUFFER-LIST)) for
 682 ;; the most recently used buffers.
 683 (defun msb--most-recently-used-menu (max-buffer-name-length)
 684   (when (and (numberp msb-display-most-recently-used)
 685              (> msb-display-most-recently-used 0))
 686     (let* ((most-recently-used
 687             (loop with n = 0
 688                   for buffer in (cdr (buffer-list))
 689                   if (save-excursion
 690                        (set-buffer buffer)
 691                        (and (not (msb-invisible-buffer-p))
 692                             (not (eq major-mode 'dired-mode))))
 693                   collect (save-excursion
 694                             (set-buffer buffer)
 695                             (cons (funcall msb-item-handling-function
 696                                            buffer
 697                                            max-buffer-name-length)
 698                                   buffer))
 699                   and do (incf n)
 700                   until (>= n msb-display-most-recently-used))))
 701       (cons (if (stringp msb-most-recently-used-title)
 702                 (format msb-most-recently-used-title
 703                         (length most-recently-used))
 704               (signal 'wrong-type-argument (list msb-most-recently-used-title)))
 705             most-recently-used))))
 706
 707 (defun msb--create-buffer-menu-2 ()
 708   (let ((max-buffer-name-length 0)
 709         file-buffers
 710         function-info-vector)
 711     ;; Calculate the longest buffer name.
 712     (mapc
 713      (function
 714       (lambda (buffer)
 715         (if (or msb-display-invisible-buffers-p
 716                 (not (msb-invisible-buffer-p)))
 717             (setq max-buffer-name-length
 718                   (max max-buffer-name-length
 719                        (length (buffer-name buffer)))))))
 720      (buffer-list))
 721     ;; Make a list with elements of type
 722     ;; (BUFFER-LIST-VARIABLE
 723     ;;  CONDITION
 724     ;;  MENU-SORT-KEY
 725     ;;  MENU-TITLE
 726     ;;  ITEM-HANDLER
 727     ;;  SORTER)
 728     ;; Uses "function-global" variables:
 729     ;; function-info-vector
 730     (setq function-info-vector
 731           (apply (function vector)
 732                  (mapcar (function msb--create-function-info)
 733                          msb-menu-cond)))
 734     ;; Split the buffer-list into several lists; one list for each
 735     ;; criteria.  This is the most critical part with respect to time.
 736     (mapc (function (lambda (buffer)
 737                       (cond ((and msb-files-by-directory
 738                                   (buffer-file-name buffer))
 739                              (push buffer file-buffers))
 740                             (t
 741                              (msb--choose-menu buffer
 742                                                function-info-vector
 743                                                max-buffer-name-length)))))
 744           (buffer-list))
 745     (when file-buffers
 746       (setq file-buffers
 747             (mapcar (function
 748                      (lambda (buffer-list)
 749                        (cons msb-files-by-directory-sort-key
 750                              (cons (car buffer-list)
 751                                    (sort
 752                                     (mapcar (function
 753                                              (lambda (buffer)
 754                                                (cons (save-excursion
 755                                                        (set-buffer buffer)
 756                                                        (funcall msb-item-handling-function
 757                                                               buffer
 758                                                               max-buffer-name-length))
 759                                                      buffer)))
 760                                             (cdr buffer-list))
 761                                     (function
 762                                      (lambda (item1 item2)
 763                                        (string< (car item1) (car item2)))))))))
 764                      (msb--choose-file-menu file-buffers))))
 765     ;; Now make the menu - a list of (TITLE . BUFFER-LIST)
 766     (let* (menu
 767            (most-recently-used
 768             (msb--most-recently-used-menu max-buffer-name-length))
 769            (others (append file-buffers
 770                            (loop for elt
 771                                  across function-info-vector
 772                                  for value = (msb--create-sort-item elt)
 773                                  if value collect value))))
 774       (setq menu
 775             (mapcar 'cdr                ;Remove the SORT-KEY
 776                     ;; Sort the menus - not the items.
 777                     (msb--add-separators
 778                     (sort
 779                      ;; Get a list of (SORT-KEY TITLE . BUFFER-LIST)
 780                      ;; Also sorts the items within the menus.
 781                      (if (cdr most-recently-used)
 782                          (cons
 783                           ;; Add most recent used buffers
 784                           (cons msb-most-recently-used-sort-key
 785                                 most-recently-used)
 786                           others)
 787                        others)
 788                      (function (lambda (elt1 elt2)
 789                                  (< (car elt1) (car elt2))))))))
 790       ;; Now make it a keymap menu
 791       (append
 792        '(keymap "Select Buffer")
 793        (msb--make-keymap-menu menu)
 794        (when msb-separator-diff
 795          (list (list 'separator "---")))
 796        (list (cons 'toggle
 797                    (cons
 798                    (if msb-files-by-directory
 799                        "*Files by type*"
 800                      "*Files by directory*")
 801                    'msb--toggle-menu-type)))))))
 802
 803 (defun msb--create-buffer-menu  ()
 804   (save-match-data
 805     (save-excursion
 806       (msb--create-buffer-menu-2))))
 807
 808 ;;;
 809 ;;; Multi purpose function for selecting a buffer with the mouse.
 810 ;;;
 811 (defun msb--toggle-menu-type ()
 812   (interactive)
 813   (setq msb-files-by-directory (not msb-files-by-directory))
 814   (menu-bar-update-buffers t))
 815
 816 (defun mouse-select-buffer (event)
 817   "Pop up several menus of buffers, for selection with the mouse.
 818 Returns the selected buffer or nil if no buffer is selected.
 819
 820 The way the buffers are split is conveniently handled with the
 821 variable `msb-menu-cond'."
 822   ;; Popup the menu and return the selected buffer.
 823   (when (or msb--error
 824             (not msb--last-buffer-menu)
 825             (not (fboundp 'frame-or-buffer-changed-p))
 826             (frame-or-buffer-changed-p))
 827     (setq msb--error nil)
 828     (setq msb--last-buffer-menu (msb--create-buffer-menu)))
 829   (let ((position event)
 830         choice)
 831     (when (and (fboundp 'posn-x-y)
 832                (fboundp 'posn-window))
 833       (let ((posX (car (posn-x-y (event-start event))))
 834             (posY (cdr (posn-x-y (event-start event))))
 835             (posWind (posn-window (event-start event))))
 836         ;; adjust position
 837         (setq posX (- posX (funcall msb-horizontal-shift-function))
 838               position (list (list posX posY) posWind))))
 839     (setq choice (x-popup-menu position msb--last-buffer-menu))
 840     (cond
 841      ((eq (car choice) 'toggle)
 842       ;; Bring up the menu again with type toggled.
 843       (msb--toggle-menu-type)
 844       (mouse-select-buffer event))
 845      ((and (numberp (car choice))
 846            (null (cdr choice)))
 847       (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice) msb--last-buffer-menu))))
 848         (mouse-select-buffer event)))
 849      ((while (numberp (car choice))
 850         (setq choice (cdr choice))))
 851      ((and (stringp (car choice))
 852            (null (cdr choice)))
 853       (car choice))
 854      (t
 855       (error "Unknown form for buffer: %s" choice)))))
 856
 857 ;; Add separators
 858 (defun msb--add-separators (sorted-list)
 859   (cond
 860    ((or (not msb-separator-diff)
 861         (not (numberp msb-separator-diff)))
 862     sorted-list)
 863    (t
 864     (let ((last-key nil))
 865       (mapcan
 866        (function
 867         (lambda (item)
 868           (cond
 869            ((and msb-separator-diff
 870                  last-key
 871                  (> (- (car item) last-key)
 872                     msb-separator-diff))
 873             (setq last-key (car item))
 874             (list (cons last-key 'separator)
 875                   item))
 876            (t
 877             (setq last-key (car item))
 878             (list item)))))
 879        sorted-list)))))
 880
 881 (defun msb--split-menus-2 (list mcount result)
 882   (cond
 883    ((> (length list) msb-max-menu-items)
 884     (let ((count 0)
 885           sub-name
 886           (tmp-list nil))
 887       (while (< count msb-max-menu-items)
 888         (push (pop list) tmp-list)
 889         (incf count))
 890     (setq tmp-list (nreverse tmp-list))
 891     (setq sub-name (concat (car (car tmp-list)) "..."))
 892     (push (append (list mcount sub-name
 893                         'keymap sub-name)
 894                   tmp-list)
 895           result))
 896     (msb--split-menus-2 list (1+ mcount) result))
 897    ((null result)
 898     list)
 899    (t
 900     (let (sub-name)
 901       (setq sub-name (concat (car (car list)) "..."))
 902       (push (append (list mcount sub-name
 903                         'keymap sub-name)
 904                   list)
 905           result))
 906     (nreverse result))))
 907
 908 (defun msb--split-menus (list)
 909  (msb--split-menus-2 list 0 nil))
 910
 911
 912 (defun msb--make-keymap-menu (raw-menu)
 913   (let ((end (cons '(nil) 'menu-bar-select-buffer))
 914         (mcount 0))
 915     (mapcar
 916      (function
 917       (lambda (sub-menu)
 918         (cond
 919          ((eq 'separator sub-menu)
 920           (list 'separator "---"))
 921          (t
 922           (let ((buffers (mapcar (function
 923                                   (lambda (item)
 924                                     (let ((string (car item))
 925                                           (buffer (cdr item)))
 926                                       (cons (buffer-name buffer)
 927                                             (cons string end)))))
 928                                  (cdr sub-menu))))
 929             (append (list (incf mcount) (car sub-menu)
 930                           'keymap (car sub-menu))
 931                     (msb--split-menus buffers)))))))
 932      raw-menu)))
 933
 934 (defun menu-bar-update-buffers (&optional arg)
 935   ;; If user discards the Buffers item, play along.
 936   (when (and (lookup-key (current-global-map) [menu-bar buffer])
 937              (or (not (fboundp 'frame-or-buffer-changed-p))
 938                  (frame-or-buffer-changed-p)
 939                  arg))
 940     (let ((buffers (buffer-list))
 941           (frames (frame-list))
 942           buffers-menu frames-menu)
 943       ;; If requested, list only the N most recently selected buffers.
 944       (when (and (integerp buffers-menu-max-size)
 945                  (> buffers-menu-max-size 1)
 946                  (> (length buffers) buffers-menu-max-size))
 947         (setcdr (nthcdr buffers-menu-max-size buffers) nil))
 948       ;; Make the menu of buffers proper.
 949       (setq msb--last-buffer-menu (msb--create-buffer-menu))
 950       (setq buffers-menu msb--last-buffer-menu)
 951       ;; Make a Frames menu if we have more than one frame.
 952       (if (cdr frames)
 953           (setq frames-menu
 954                 (cons "Select Frame"
 955                       (mapcar
 956                        (function
 957                         (lambda (frame)
 958                           (nconc
 959                            (list frame
 960                                  (cdr (assq 'name
 961                                             (frame-parameters frame)))
 962                                  (cons nil nil))
 963                            'menu-bar-select-frame)))
 964                        frames))))
 965       (when frames-menu
 966         (setq frames-menu (cons 'keymap frames-menu)))
 967       (define-key (current-global-map) [menu-bar buffer]
 968         (cons "Buffers"
 969               (if (and buffers-menu frames-menu)
 970                   (list 'keymap "Buffers and Frames"
 971                         (cons 'buffers (cons "Buffers" buffers-menu))
 972                         (cons 'frames (cons "Frames" frames-menu)))
 973                 (or buffers-menu frames-menu 'undefined)))))))
 974
 975 (when (and (boundp 'menu-bar-update-hook)
 976            (not (fboundp 'frame-or-buffer-changed-p)))
 977   (defvar msb--buffer-count 0)
 978   (defun frame-or-buffer-changed-p ()
 979     (let ((count (length (buffer-list))))
 980       (when (/= count msb--buffer-count)
 981         (setq msb--buffer-count count)
 982         t))))
 983
 984 (unless (or (not (boundp 'menu-bar-update-hook))
 985             (memq 'menu-bar-update-buffers menu-bar-update-hook))
 986     (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers))
 987
 988 (and (fboundp 'mouse-buffer-menu)
 989      (substitute-key-definition 'mouse-buffer-menu 'msb (current-global-map)))
 990
 991 (provide 'msb)
 992 (eval-after-load 'msb (run-hooks 'msb-after-load-hooks))
 993 ;;; msb.el ends here