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