X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/3e0439449b6b979d7b5dc558e14e259e6a864b21..773415d9340f12db3bd8654de5014deec57d49b7:/lisp/msb.el diff --git a/lisp/msb.el b/lisp/msb.el index 83ca200dff..2ab7fe5491 100644 --- a/lisp/msb.el +++ b/lisp/msb.el @@ -1,41 +1,38 @@ -;;; msb.el --- Customizable buffer-selection with multiple menus. -;; Copyright (C) 1993, 1994, 1995 Lars Lindberg -;; -;; Author: Lars Lindberg +;;; msb.el --- customizable buffer-selection with multiple menus + +;; Copyright (C) 1993, 94, 95, 97, 98, 99, 2000, 2001, 2003 +;; Free Software Foundation, Inc. + +;; Author: Lars Lindberg +;; Maintainer: FSF ;; Created: 8 Oct 1993 -;; Lindberg's last update version: 3.31 -;; Keywords: mouse buffer menu -;; -;; This program is free software; you can redistribute it and/or modify +;; Lindberg's last update version: 3.34 +;; Keywords: mouse buffer menu + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. -;; + ;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: -;; + ;; Purpose of this package: ;; 1. Offer a function for letting the user choose buffer, ;; not necessarily for switching to it. -;; 2. Make a better mouse-buffer-menu. -;; -;; Installation: - -;; 1. Byte compile msb first. It uses things in the cl package that -;; are slow if not compiled, but blazingly fast when compiled. I -;; have also had one report that said that msb malfunctioned when -;; not compiled. -;; 2. (require 'msb) -;; Note! You now use msb instead of mouse-buffer-menu. -;; 3. Now try the menu bar Buffers menu. +;; 2. Make a better mouse-buffer-menu. This is done as a global +;; minor mode, msb-mode. ;; ;; Customization: ;; Look at the variable `msb-menu-cond' for deciding what menus you @@ -44,11 +41,11 @@ ;; There are some constants for you to try here: ;; msb--few-menus ;; msb--very-many-menus (default) -;; +;; ;; Look at the variable `msb-item-handling-function' for customization ;; of the appearance of every menu item. Try for instance setting ;; it to `msb-alon-item-handler'. -;; +;; ;; Look at the variable `msb-item-sort-function' for customization ;; of sorting the menus. Set it to t for instance, which means no ;; sorting - you will get latest used buffer first. @@ -58,7 +55,7 @@ ;; Known bugs: ;; - Files-by-directory ;; + No possibility to show client/changed buffers separately. -;; + All file buffers only appear in in a file sub-menu, they will +;; + All file buffers only appear in a file sub-menu, they will ;; for instance not appear in the Mail sub-menu. ;; Future enhancements: @@ -76,12 +73,14 @@ ;; Alon Albert ;; Kevin Broadey, ;; Ake Stenhof -;; Richard Stallman +;; Richard Stallman ;; Steve Fisk +;; This version turned into a global minor mode and subsequently +;; hacked on by Dave Love. ;;; Code: -(require 'cl) +(eval-when-compile (require 'cl)) ;;; ;;; Some example constants to be used for `msb-menu-cond'. See that @@ -110,16 +109,12 @@ ((eq major-mode 'w3-mode) 4020 "WWW (%d)") - ((or (memq major-mode '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode)) - (memq major-mode '(mh-letter-mode - mh-show-mode - mh-folder-mode)) - (memq major-mode '(gnus-summary-mode - news-reply-mode - gnus-group-mode - gnus-article-mode - gnus-kill-file-mode - gnus-browse-killed-mode))) + ((or (memq major-mode + '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode)) + (memq major-mode '(mh-letter-mode mh-show-mode mh-folder-mode)) + (memq major-mode + '(gnus-summary-mode message-mode gnus-group-mode + gnus-article-mode score-mode gnus-browse-killed-mode))) 4010 "Mail (%d)") ((not buffer-file-name) @@ -151,7 +146,7 @@ (msb-invisible-buffer-p) 'multi) 1090 - "Invisible buffers (%d)") + "Invisible buffers (%d)") ((eq major-mode 'dired-mode) 2010 "Dired (%d)" @@ -160,27 +155,23 @@ ;; Also note this item-sorter msb-sort-by-directory) ((eq major-mode 'Man-mode) - 4030 + 5030 "Manuals (%d)") ((eq major-mode 'w3-mode) - 4020 + 5020 "WWW (%d)") - ((or (memq major-mode '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode)) - (memq major-mode '(mh-letter-mode - mh-show-mode - mh-folder-mode)) - (memq major-mode '(gnus-summary-mode - news-reply-mode - gnus-group-mode - gnus-article-mode - gnus-kill-file-mode + ((or (memq major-mode + '(rmail-mode rmail-edit-mode vm-summary-mode vm-mode mail-mode)) + (memq major-mode '(mh-letter-mode mh-show-mode mh-folder-mode)) + (memq major-mode '(gnus-summary-mode message-mode gnus-group-mode + gnus-article-mode score-mode gnus-browse-killed-mode))) - 4010 + 5010 "Mail (%d)") ;; Catchup for all non-file buffers ((and (not buffer-file-name) 'no-multi) - 4099 + 5099 "Other non-file buffers (%d)") ((and (string-match "/\\.[^/]*$" buffer-file-name) 'multi) @@ -206,48 +197,140 @@ ;;; Customizable variables ;;; -(defvar msb-separator-diff 100 +(defgroup msb nil + "Customizable buffer-selection with multiple menus." + :prefix "msb-" + :group 'mouse) + +(defun msb-custom-set (symbol value) + "Set the value of custom variables for msb." + (set symbol value) + (if (and (featurep 'msb) msb-mode) + ;; wait until package has been loaded before bothering to update + ;; the buffer lists. + (msb-menu-bar-update-buffers t))) + +(defcustom msb-menu-cond msb--very-many-menus + "*List of criteria for splitting the mouse buffer menu. +The elements in the list should be of this type: + (CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLING-FN ITEM-SORT-FN). + +When making the split, the buffers are tested one by one against the +CONDITION, just like a Lisp cond: When hitting a true condition, the +other criteria are *not* tested and the buffer name will appear in the +menu with the menu-title corresponding to the true condition. + +If the condition returns the symbol `multi', then the buffer will be +added to this menu *and* tested for other menus too. If it returns +`no-multi', then the buffer will only be added if it hasn't been added +to any other menu. + +During this test, the buffer in question is the current buffer, and +the test is surrounded by calls to `save-excursion' and +`save-match-data'. + +The categories are sorted by MENU-SORT-KEY. Smaller keys are on top. +nil means don't display this menu. + +MENU-TITLE is really a format. If you add %d in it, the %d is +replaced with the number of items in that menu. + +ITEM-HANDLING-FN, is optional. If it is supplied and is a function, +than it is used for displaying the items in that particular buffer +menu, otherwise the function pointed out by +`msb-item-handling-function' is used. + +ITEM-SORT-FN, is also optional. +If it is not supplied, the function pointed out by +`msb-item-sort-function' is used. +If it is nil, then no sort takes place and the buffers are presented +in least-recently-used order. +If it is t, then no sort takes place and the buffers are presented in +most-recently-used order. +If it is supplied and non-nil and not t than it is used for sorting +the items in that particular buffer menu. + +Note1: There should always be a `catch-all' as last element, in this +list. That is an element like (t TITLE ITEM-HANDLING-FUNCTION). +Note2: A buffer menu appears only if it has at least one buffer in it. +Note3: If you have a CONDITION that can't be evaluated you will get an +error every time you do \\[msb]." + :type `(choice (const :tag "long" :value ,msb--very-many-menus) + (const :tag "short" :value ,msb--few-menus) + (sexp :tag "user")) + :set 'msb-custom-set + :group 'msb) + +(defcustom msb-modes-key 4000 + "The sort key for files sorted by mode." + :type 'integer + :set 'msb-custom-set + :group 'msb + :version "20.3") + +(defcustom msb-separator-diff 100 "*Non-nil means use separators. -The separators will appear between all menus that have a sorting key that differs by this value or more.") +The separators will appear between all menus that have a sorting key +that differs by this value or more." + :type '(choice integer (const nil)) + :set 'msb-custom-set + :group 'msb) (defvar msb-files-by-directory-sort-key 0 - "*The sort key for files sorted by directory") + "*The sort key for files sorted by directory.") -(defvar msb-max-menu-items 15 +(defcustom msb-max-menu-items 15 "*The maximum number of items in a menu. -If this variable is set to 15 for instance, then the submenu will be split up in minor parts, 15 items each. -Nil means no limit.") +If this variable is set to 15 for instance, then the submenu will be +split up in minor parts, 15 items each. nil means no limit." + :type '(choice integer (const nil)) + :set 'msb-custom-set + :group 'msb) -(defvar msb-max-file-menu-items 10 +(defcustom msb-max-file-menu-items 10 "*The maximum number of items from different directories. When the menu is of type `file by directory', this is the maximum -number of buffers that are clumped togehter from different +number of buffers that are clumped together from different directories. Set this to 1 if you want one menu per directory instead of clumping them together. -If the value is not a number, then the value 10 is used.") +If the value is not a number, then the value 10 is used." + :type 'integer + :set 'msb-custom-set + :group 'msb) -(defvar msb-most-recently-used-sort-key -1010 - "*Where should the menu with the most recently used buffers be placed?") +(defcustom msb-most-recently-used-sort-key -1010 + "*Where should the menu with the most recently used buffers be placed?" + :type 'integer + :set 'msb-custom-set + :group 'msb) -(defvar msb-display-most-recently-used 15 +(defcustom msb-display-most-recently-used 15 "*How many buffers should be in the most-recently-used menu. - No buffers at all if less than 1 or nil (or any non-number).") +No buffers at all if less than 1 or nil (or any non-number)." + :type 'integer + :set 'msb-custom-set + :group 'msb) + +(defcustom msb-most-recently-used-title "Most recently used (%d)" + "*The title for the most-recently-used menu." + :type 'string + :set 'msb-custom-set + :group 'msb) -(defvar msb-most-recently-used-title "Most recently used (%d)" - "*The title for the most-recently-used menu.") - (defvar msb-horizontal-shift-function '(lambda () 0) - "*Function that specifies a number of pixels by which the top menu should -be shifted leftwards.") + "*Function that specifies how many pixels to shift the top menu leftwards.") -(defvar msb-display-invisible-buffers-p nil +(defcustom msb-display-invisible-buffers-p nil "*Show invisible buffers or not. Non-nil means that the buffer menu should include buffers that have -names that starts with a space character.") +names that starts with a space character." + :type 'boolean + :set 'msb-custom-set + :group 'msb) (defvar msb-item-handling-function 'msb-item-handler "*The appearance of a buffer menu. @@ -258,73 +341,40 @@ where the latter is the max length of all buffer names. The function should return the string to use in the menu. -When the function is called, BUFFER is the current buffer. -This function is called for items in the variable `msb-menu-cond' that -have nil as ITEM-HANDLING-FUNCTION. See `msb-menu-cond' for more +When the function is called, BUFFER is the current buffer. This +function is called for items in the variable `msb-menu-cond' that have +nil as ITEM-HANDLING-FUNCTION. See `msb-menu-cond' for more information.") -(defvar msb-item-sort-function 'msb-sort-by-name +(defcustom msb-item-sort-function 'msb-sort-by-name "*The order of items in a buffer menu. + The default function to call for handling the order of items in a menu -item. This function is called like a sort function. The items -look like (ITEM-NAME . BUFFER). +item. This function is called like a sort function. The items look +like (ITEM-NAME . BUFFER). + ITEM-NAME is the name of the item that will appear in the menu. BUFFER is the buffer, this is not necessarily the current buffer. -Set this to nil or t if you don't want any sorting (faster).") - -(defvar msb-files-by-directory nil - "*Non-nil means that files should be sorted by directory instead of -the groups in msb-menu-cond.") - -(defvar msb-menu-cond msb--very-many-menus - "*List of criterias for splitting the mouse buffer menu. -The elements in the list should be of this type: - (CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLING-FN ITEM-SORT-FN). - -When making the split, the buffers are tested one by one against the -CONDITION, just like a lisp cond: When hitting a true condition, the -other criterias are *not* tested and the buffer name will appear in -the menu with the menu-title corresponding to the true condition. - -If the condition returns the symbol `multi', then the buffer will be -added to this menu *and* tested for other menus too. If it returns -`no-multi', then the buffer will only be added if it hasn't been added -to any other menu. - -During this test, the buffer in question is the current buffer, and -the test is surrounded by calls to `save-excursion' and -`save-match-data'. - -The categories are sorted by MENU-SORT-KEY. Smaller keys are on -top. nil means don't display this menu. - -MENU-TITLE is really a format. If you add %d in it, the %d is replaced -with the number of items in that menu. - -ITEM-HANDLING-FN, is optional. If it is supplied and is a -function, than it is used for displaying the items in that particular -buffer menu, otherwise the function pointed out by -`msb-item-handling-function' is used. - -ITEM-SORT-FN, is also optional. -If it is not supplied, the function pointed out by -`msb-item-sort-function' is used. -If it is nil, then no sort takes place and the buffers are presented -in least-recently-used order. -If it is t, then no sort takes place and the buffers are presented in -most-recently-used order. -If it is supplied and non-nil and not t than it is used for sorting -the items in that particular buffer menu. - -Note1: There should always be a `catch-all' as last element, -in this list. That is an element like (t TITLE ITEM-HANDLING-FUNCTION). -Note2: A buffer menu appears only if it has at least one buffer in it. -Note3: If you have a CONDITION that can't be evaluated you will get an -error every time you do \\[msb].") - -(defvar msb-after-load-hooks nil - "Hooks to be run after the msb package has been loaded.") +Set this to nil or t if you don't want any sorting (faster)." + :type '(choice (const msb-sort-by-name) + (const :tag "Newest first" t) + (const :tag "Oldest first" nil)) + :set 'msb-custom-set + :group 'msb) + +(defcustom msb-files-by-directory nil + "*Non-nil means that files should be sorted by directory. +This is instead of the groups in `msb-menu-cond'." + :type 'boolean + :set 'msb-custom-set + :group 'msb) + +(defcustom msb-after-load-hook nil + "Hook run after the msb package has been loaded." + :type 'hook + :set 'msb-custom-set + :group 'msb) ;;; ;;; Internal variables @@ -395,24 +445,26 @@ The `#' appears only version control file (SCCS/RCS)." ;;; Some example function to be used for `msb-item-sort-function'. ;;; (defun msb-sort-by-name (item1 item2) - "Sorts the items depending on their buffer-name -An item look like (NAME . BUFFER)." + "Sort the items ITEM1 and ITEM2 by their `buffer-name'. +An item looks like (NAME . BUFFER)." (string-lessp (buffer-name (cdr item1)) (buffer-name (cdr item2)))) (defun msb-sort-by-directory (item1 item2) - "Sorts the items depending on their directory. Made for dired. + "Sort the items ITEM1 and ITEM2 by directory name. Made for dired. An item look like (NAME . BUFFER)." - (string-lessp (save-excursion (set-buffer (cdr item1)) (msb--dired-directory)) - (save-excursion (set-buffer (cdr item2)) (msb--dired-directory)))) + (string-lessp (save-excursion (set-buffer (cdr item1)) + (msb--dired-directory)) + (save-excursion (set-buffer (cdr item2)) + (msb--dired-directory)))) ;;; ;;; msb ;;; ;;; This function can be used instead of (mouse-buffer-menu EVENT) ;;; function in "mouse.el". -;;; +;;; (defun msb (event) "Pop up several menus of buffers for selection with the mouse. This command switches buffers in the window that you clicked on, and @@ -439,136 +491,174 @@ If the argument is left out or nil, then the current buffer is considered." (and (> (length (buffer-name buffer)) 0) (eq ?\ (aref (buffer-name buffer) 0)))) -;; Strip one hierarcy level from the end of PATH. -(defun msb--strip-path (path) - (save-match-data - (if (string-match "\\(.+\\)/[^/]+$" path) - (substring path (match-beginning 1) (match-end 1)) - "/"))) +(defun msb--strip-dir (dir) + "Strip one hierarchy level from the end of DIR." + (file-name-directory (directory-file-name dir))) ;; Create an alist with all buffers from LIST that lies under the same -;; directory will be in the same item as the directory string as -;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K BUFFER-K+1...)) ...) +;; directory will be in the same item as the directory name. +;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K BUFFER-K+1...)) ...) (defun msb--init-file-alist (list) (let ((buffer-alist - (sort (mapcan - (function - (lambda (buffer) - (let ((file-name (buffer-file-name buffer))) - (when file-name - (list (cons (msb--strip-path file-name) buffer)))))) - list) - (function (lambda (item1 item2) - (string< (car item1) (car item2))))))) + ;; Make alist that looks like + ;; ((DIR-1 BUFFER-1) (DIR-2 BUFFER-2) ...) + ;; sorted on DIR-x + (sort + (apply #'nconc + (mapcar + (lambda (buffer) + (let ((file-name (expand-file-name + (buffer-file-name buffer)))) + (when file-name + (list (cons (msb--strip-dir file-name) buffer))))) + list)) + (lambda (item1 item2) + (string< (car item1) (car item2)))))) + ;; Now clump buffers together that have the same directory name ;; Make alist that looks like - ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K)) ...) - (let ((path nil) - (buffers nil) - (result nil)) - (append - (mapcan (function - (lambda (item) - (cond - ((and path - (string= path (car item))) - (push (cdr item) buffers) - nil) - (t - (when path - (setq result (cons path buffers))) - (setq path (car item)) - (setq buffers (list (cdr item))) - (and result (list result)))))) - buffer-alist) - (list (cons path buffers)))))) - -;; Choose file-menu with respect to directory for every buffer in LIST. + ;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K)) ...) + (let ((dir nil) + (buffers nil)) + (nconc + (apply + #'nconc + (mapcar (lambda (item) + (cond + ((equal dir (car item)) + ;; The same dir as earlier: + ;; Add to current list of buffers. + (push (cdr item) buffers) + ;; This item should not be added to list + nil) + (t + ;; New dir + (let ((result (and dir (cons dir buffers)))) + (setq dir (car item)) + (setq buffers (list (cdr item))) + ;; Add the last result the list. + (and result (list result)))))) + buffer-alist)) + ;; Add the last result to the list + (list (cons dir buffers)))))) + +(defun msb--format-title (top-found-p dir number-of-items) + "Format a suitable title for the menu item." + (format (if top-found-p "%s... (%d)" "%s (%d)") + (abbreviate-file-name dir) number-of-items)) + +;; Variables for debugging. +(defvar msb--choose-file-menu-list) +(defvar msb--choose-file-menu-arg-list) + (defun msb--choose-file-menu (list) + "Choose file-menu with respect to directory for every buffer in LIST." + (setq msb--choose-file-menu-arg-list list) (let ((buffer-alist (msb--init-file-alist list)) (final-list nil) (max-clumped-together (if (numberp msb-max-file-menu-items) msb-max-file-menu-items 10)) (top-found-p nil) - (last-path nil) - first rest path buffers) - (setq first (car buffer-alist)) - (setq rest (cdr buffer-alist)) - (setq path (car first)) - (setq buffers (cdr first)) + (last-dir nil) + first rest dir buffers old-dir) + ;; Prepare for looping over all items in buffer-alist + (setq first (car buffer-alist) + rest (cdr buffer-alist) + dir (car first) + buffers (cdr first)) + (setq msb--choose-file-menu-list (copy-sequence rest)) + ;; This big loop tries to clump buffers together that have a + ;; similar name. Remember that buffer-alist is sorted based on the + ;; directory name of the buffers' visited files. (while rest (let ((found-p nil) (tmp-rest rest) - new-path item) + result + new-dir item) (setq item (car tmp-rest)) + ;; Clump together the "rest"-buffers that have a dir that is + ;; a subdir of the current one. (while (and tmp-rest (<= (length buffers) max-clumped-together) - (>= (length (car item)) (length path)) - (string= path (substring (car item) 0 (length path)))) + (>= (length (car item)) (length dir)) + ;; `completion-ignore-case' seems to default to t + ;; on the systems with case-insensitive file names. + (eq t (compare-strings dir 0 nil + (car item) 0 (length dir) + completion-ignore-case))) (setq found-p t) - (setq buffers (append buffers (cdr item))) - (setq tmp-rest (cdr tmp-rest)) - (setq item (car tmp-rest))) + (setq buffers (append buffers (cdr item))) ;nconc is faster than append + (setq tmp-rest (cdr tmp-rest) + item (car tmp-rest))) (cond ((> (length buffers) max-clumped-together) - (setq last-path (car first)) - (setq first - (cons (format (if top-found-p - "%s/... (%d)" - "%s (%d)") - (car first) - (length (cdr first))) - (cdr first))) + ;; Oh, we failed. Too many buffers clumped together. + ;; Just use the original ones for the result. + (setq last-dir (car first)) + (push (cons (msb--format-title top-found-p + (car first) + (length (cdr first))) + (cdr first)) + final-list) (setq top-found-p nil) - (push first final-list) (setq first (car rest) - rest (cdr rest)) - (setq path (car first) + rest (cdr rest) + dir (car first) buffers (cdr first))) (t + ;; The first pass of clumping together worked out, go ahead + ;; with this result. (when found-p (setq top-found-p t) - (setq first (cons path buffers) + (setq first (cons dir buffers) rest tmp-rest)) - (setq path (msb--strip-path path) + ;; Now see if we can clump more buffers together if we go up + ;; one step in the file hierarchy. + ;; If dir isn't changed by msb--strip-dir, we are looking + ;; at the machine name component of an ange-ftp filename. + (setq old-dir dir) + (setq dir (msb--strip-dir dir) buffers (cdr first)) - (when (and last-path - (or (and (>= (length path) (length last-path)) - (string= last-path - (substring path 0 (length last-path)))) - (and (< (length path) (length last-path)) - (string= path - (substring last-path 0 (length path)))))) - - (setq first - (cons (format (if top-found-p - "%s/... (%d)" - "%s (%d)") - (car first) - (length (cdr first))) - (cdr first))) + (if (equal old-dir dir) + (setq last-dir dir)) + (when (and last-dir + (or (and (>= (length dir) (length last-dir)) + (eq t (compare-strings + last-dir 0 nil dir 0 + (length last-dir) + completion-ignore-case))) + (and (< (length dir) (length last-dir)) + (eq t (compare-strings + dir 0 nil last-dir 0 (length dir) + completion-ignore-case))))) + ;; We have reached the same place in the file hierarchy as + ;; the last result, so we should quit at this point and + ;; take what we have as result. + (push (cons (msb--format-title top-found-p + (car first) + (length (cdr first))) + (cdr first)) + final-list) (setq top-found-p nil) - (push first final-list) (setq first (car rest) - rest (cdr rest)) - (setq path (car first) - buffers (cdr first))))))) - (setq first - (cons (format (if top-found-p - "%s/... (%d)" - "%s (%d)") - (car first) - (length (cdr first))) - (cdr first))) + rest (cdr rest) + dir (car first) + buffers (cdr first))))))) + ;; Now take care of the last item. + (when first + (push (cons (msb--format-title top-found-p + (car first) + (length (cdr first))) + (cdr first)) + final-list)) (setq top-found-p nil) - (push first final-list) (nreverse final-list))) -;; Create a vector as: -;; [BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER) -;; from an element in `msb-menu-cond'. See that variable for a -;; description of its elements. (defun msb--create-function-info (menu-cond-elt) + "Create a vector from an element MENU-COND-ELT of `msb-menu-cond'. +This takes the form: +\]BUFFER-LIST-VARIABLE CONDITION MENU-SORT-KEY MENU-TITLE ITEM-HANDLER SORTER) +See `msb-menu-cond' for a description of its elements." (let* ((list-symbol (make-symbol "-msb-buffer-list")) (tmp-ih (and (> (length menu-cond-elt) 3) (nth 3 menu-cond-elt))) @@ -581,10 +671,10 @@ If the argument is left out or nil, then the current buffer is considered." (sorter (if (or (fboundp tmp-s) (null tmp-s) (eq tmp-s t)) - tmp-s + tmp-s msb-item-sort-function))) (when (< (length menu-cond-elt) 3) - (error "Wrong format of msb-menu-cond.")) + (error "Wrong format of msb-menu-cond")) (when (and (> (length menu-cond-elt) 3) (not (fboundp tmp-ih))) (signal 'invalid-function (list tmp-ih))) @@ -603,7 +693,7 @@ If the argument is left out or nil, then the current buffer is considered." )) ;; This defsubst is only used in `msb--choose-menu' below. It was -;; pulled out merely to make the code somewhat clearer. The indention +;; pulled out merely to make the code somewhat clearer. The indentation ;; level was too big. (defsubst msb--collect (function-info-vector) (let ((result nil) @@ -627,10 +717,10 @@ If the argument is left out or nil, then the current buffer is considered." (error "No catch-all in msb-menu-cond!")) function-info-list)) -;; Adds BUFFER to the menu depicted by FUNCTION-INFO -;; All side-effects. Adds an element of form (BUFFER-TITLE . BUFFER) -;; to the buffer-list variable in function-info. (defun msb--add-to-menu (buffer function-info max-buffer-name-length) + "Add BUFFER to the menu depicted by FUNCTION-INFO. +All side-effects. Adds an element of form (BUFFER-TITLE . BUFFER) +to the buffer-list variable in function-info." (let ((list-symbol (aref function-info 0))) ;BUFFER-LIST-VARIABLE ;; Here comes the hairy side-effect! (set list-symbol @@ -639,37 +729,34 @@ If the argument is left out or nil, then the current buffer is considered." max-buffer-name-length) buffer) (eval list-symbol))))) - -;; Selects the appropriate menu for BUFFER. -;; This is all side-effects, folks! -;; This should be optimized. + (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length) + "Select the appropriate menu for BUFFER." + ;; This is all side-effects, folks! + ;; This should be optimized. (unless (and (not msb-display-invisible-buffers-p) (msb-invisible-buffer-p buffer)) (condition-case nil (save-excursion (set-buffer buffer) ;; Menu found. Add to this menu - (mapc (function - (lambda (function-info) - (msb--add-to-menu buffer function-info max-buffer-name-length))) - (msb--collect function-info-vector))) + (dolist (info (msb--collect function-info-vector)) + (msb--add-to-menu buffer info max-buffer-name-length))) (error (unless msb--error (setq msb--error (format "In msb-menu-cond, error for buffer `%s'." (buffer-name buffer))) - (error msb--error)))))) + (error "%s" msb--error)))))) -;; Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the -;; buffer-list is empty. (defun msb--create-sort-item (function-info) + "Return (SORT-KEY TITLE . BUFFER-LIST) or nil if the buffer-list is empty." (let ((buffer-list (eval (aref function-info 0)))) (when buffer-list (let ((sorter (aref function-info 5)) ;SORTER (sort-key (aref function-info 2))) ;MENU-SORT-KEY (when sort-key - (cons sort-key + (cons sort-key (cons (format (aref function-info 3) ;MENU-TITLE (length buffer-list)) (cond @@ -680,9 +767,75 @@ If the argument is left out or nil, then the current buffer is considered." (t (sort buffer-list sorter)))))))))) -;; Returns a list on the form ((TITLE . BUFFER-LIST)) for -;; the most recently used buffers. +(defun msb--aggregate-alist (alist same-predicate sort-predicate) + "Return ALIST as a sorted, aggregated alist. + +In the result all items with the same car element (according to +SAME-PREDICATE) are aggregated together. The alist is first sorted by +SORT-PREDICATE. + +Example: +\(msb--aggregate-alist + '((a . a1) (a . a2) (b . b1) (c . c3) (a . a4) (a . a3) (b . b3) (b . b2)) + (function string=) + (lambda (item1 item2) + (string< (symbol-name item1) (symbol-name item2)))) +results in +\((a a1 a2 a4 a3) (b b1 b3 b2) (c c3))" + (when (not (null alist)) + (let (result + same + tmp-old-car + tmp-same + (first-time-p t) + old-car) + (nconc + (apply #'nconc + (mapcar + (lambda (item) + (cond + (first-time-p + (push (cdr item) same) + (setq first-time-p nil) + (setq old-car (car item)) + nil) + ((funcall same-predicate (car item) old-car) + (push (cdr item) same) + nil) + (t + (setq tmp-same same + tmp-old-car old-car) + (setq same (list (cdr item)) + old-car (car item)) + (list (cons tmp-old-car (nreverse tmp-same)))))) + (sort alist (lambda (item1 item2) + (funcall sort-predicate (car item1) (car item2)))))) + (list (cons old-car (nreverse same))))))) + + +(defun msb--mode-menu-cond () + (let ((key msb-modes-key)) + (mapcar (lambda (item) + (incf key) + (list `( eq major-mode (quote ,(car item))) + key + (concat (cdr item) " (%d)"))) + (sort + (let ((mode-list nil)) + (dolist (buffer (cdr (buffer-list))) + (save-excursion + (set-buffer buffer) + (when (and (not (msb-invisible-buffer-p)) + (not (assq major-mode mode-list))) + (push (cons major-mode mode-name) + mode-list)))) + mode-list) + (lambda (item1 item2) + (string< (cdr item1) (cdr item2))))))) + (defun msb--most-recently-used-menu (max-buffer-name-length) + "Return a list for the most recently used buffers. +It takes the form ((TITLE . BUFFER-LIST)...)." (when (and (numberp msb-display-most-recently-used) (> msb-display-most-recently-used 0)) (let* ((buffers (cdr (buffer-list))) @@ -712,15 +865,11 @@ If the argument is left out or nil, then the current buffer is considered." file-buffers function-info-vector) ;; Calculate the longest buffer name. - (mapc - (function - (lambda (buffer) - (if (or msb-display-invisible-buffers-p + (dolist (buffer (buffer-list)) + (when (or msb-display-invisible-buffers-p (not (msb-invisible-buffer-p))) - (setq max-buffer-name-length - (max max-buffer-name-length - (length (buffer-name buffer))))))) - (buffer-list)) + (setq max-buffer-name-length + (max max-buffer-name-length (length (buffer-name buffer)))))) ;; Make a list with elements of type ;; (BUFFER-LIST-VARIABLE ;; CONDITION @@ -733,43 +882,45 @@ If the argument is left out or nil, then the current buffer is considered." (setq function-info-vector (apply (function vector) (mapcar (function msb--create-function-info) - msb-menu-cond))) + (append msb-menu-cond (msb--mode-menu-cond))))) ;; Split the buffer-list into several lists; one list for each ;; criteria. This is the most critical part with respect to time. - (mapc (function (lambda (buffer) - (cond ((and msb-files-by-directory - (buffer-file-name buffer)) - (push buffer file-buffers)) - (t - (msb--choose-menu buffer - function-info-vector - max-buffer-name-length))))) - (buffer-list)) + (dolist (buffer (buffer-list)) + (cond ((and msb-files-by-directory + (buffer-file-name buffer) + ;; exclude ange-ftp buffers + ;;(not (string-match "\\/[^/:]+:" + ;; (buffer-file-name buffer))) + ) + (push buffer file-buffers)) + (t + (msb--choose-menu buffer + function-info-vector + max-buffer-name-length)))) (when file-buffers (setq file-buffers - (mapcar (function - (lambda (buffer-list) - (cons msb-files-by-directory-sort-key - (cons (car buffer-list) - (sort - (mapcar (function - (lambda (buffer) - (cons (save-excursion - (set-buffer buffer) - (funcall msb-item-handling-function - buffer - max-buffer-name-length)) - buffer))) - (cdr buffer-list)) - (function - (lambda (item1 item2) - (string< (car item1) (car item2))))))))) + (mapcar (lambda (buffer-list) + (cons msb-files-by-directory-sort-key + (cons (car buffer-list) + (sort + (mapcar (function + (lambda (buffer) + (cons (save-excursion + (set-buffer buffer) + (funcall msb-item-handling-function + buffer + max-buffer-name-length)) + buffer))) + (cdr buffer-list)) + (function + (lambda (item1 item2) + (string< (car item1) (car item2)))))))) (msb--choose-file-menu file-buffers)))) ;; Now make the menu - a list of (TITLE . BUFFER-LIST) (let* (menu (most-recently-used (msb--most-recently-used-menu max-buffer-name-length)) - (others (append file-buffers + (others (nconc file-buffers (loop for elt across function-info-vector for value = (msb--create-sort-item elt) @@ -788,33 +939,33 @@ If the argument is left out or nil, then the current buffer is considered." most-recently-used) others) others) - (function (lambda (elt1 elt2) - (< (car elt1) (car elt2)))))))) + (lambda (elt1 elt2) + (< (car elt1) (car elt2))))))) ;; Now make it a keymap menu (append '(keymap "Select Buffer") (msb--make-keymap-menu menu) (when msb-separator-diff - (list (list 'separator "---"))) - (list (cons 'toggle + (list (list 'separator "--"))) + (list (cons 'toggle (cons (if msb-files-by-directory - "*Files by type*" - "*Files by directory*") - 'msb--toggle-menu-type))))))) + "*Files by type*" + "*Files by directory*") + 'msb--toggle-menu-type))))))) (defun msb--create-buffer-menu () (save-match-data (save-excursion (msb--create-buffer-menu-2)))) -;;; -;;; Multi purpose function for selecting a buffer with the mouse. -;;; (defun msb--toggle-menu-type () + "Multi purpose function for selecting a buffer with the mouse." (interactive) (setq msb-files-by-directory (not msb-files-by-directory)) - (menu-bar-update-buffers)) + ;; This gets a warning, but it is correct, + ;; because this file redefines menu-bar-update-buffers. + (msb-menu-bar-update-buffers t)) (defun mouse-select-buffer (event) "Pop up several menus of buffers, for selection with the mouse. @@ -840,7 +991,7 @@ variable `msb-menu-cond'." (setq posX (- posX (funcall msb-horizontal-shift-function)) position (list (list posX posY) posWind)))) ;; This `sit-for' magically makes the menu stay up if the mouse - ;; button is released withing 0.1 second. + ;; button is released within 0.1 second. (sit-for 0 100) ;; Popup the menu (setq choice (x-popup-menu position msb--last-buffer-menu)) @@ -851,7 +1002,8 @@ variable `msb-menu-cond'." (mouse-select-buffer event)) ((and (numberp (car choice)) (null (cdr choice))) - (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice) msb--last-buffer-menu)))) + (let ((msb--last-buffer-menu (nthcdr 3 (assq (car choice) + msb--last-buffer-menu)))) (mouse-select-buffer event))) ((while (numberp (car choice)) (setq choice (cdr choice)))) @@ -862,30 +1014,28 @@ variable `msb-menu-cond'." choice) (t (error "Unknown form for buffer: %s" choice))))) - + ;; Add separators (defun msb--add-separators (sorted-list) - (cond - ((or (not msb-separator-diff) - (not (numberp msb-separator-diff))) - sorted-list) - (t + (if (or (not msb-separator-diff) + (not (numberp msb-separator-diff))) + sorted-list (let ((last-key nil)) - (mapcan - (function - (lambda (item) - (cond - ((and msb-separator-diff - last-key - (> (- (car item) last-key) - msb-separator-diff)) - (setq last-key (car item)) - (list (cons last-key 'separator) - item)) - (t - (setq last-key (car item)) - (list item))))) - sorted-list))))) + (apply #'nconc + (mapcar + (lambda (item) + (cond + ((and msb-separator-diff + last-key + (> (- (car item) last-key) + msb-separator-diff)) + (setq last-key (car item)) + (list (cons last-key 'separator) + item)) + (t + (setq last-key (car item)) + (list item)))) + sorted-list))))) (defun msb--split-menus-2 (list mcount result) (cond @@ -896,51 +1046,49 @@ variable `msb-menu-cond'." (while (< count msb-max-menu-items) (push (pop list) tmp-list) (incf count)) - (setq tmp-list (nreverse tmp-list)) - (setq sub-name (concat (car (car tmp-list)) "...")) - (push (append (list mcount sub-name - 'keymap sub-name) - tmp-list) - result)) + (setq tmp-list (nreverse tmp-list)) + (setq sub-name (concat (car (car tmp-list)) "...")) + (push (nconc (list mcount sub-name + 'keymap sub-name) + tmp-list) + result)) (msb--split-menus-2 list (1+ mcount) result)) ((null result) list) (t (let (sub-name) (setq sub-name (concat (car (car list)) "...")) - (push (append (list mcount sub-name - 'keymap sub-name) - list) - result)) + (push (nconc (list mcount sub-name 'keymap sub-name) + list) + result)) (nreverse result)))) - -(defun msb--split-menus (list) - (msb--split-menus-2 list 0 nil)) +(defun msb--split-menus (list) + (if (and (integerp msb-max-menu-items) + (> msb-max-menu-items 0)) + (msb--split-menus-2 list 0 nil) + list)) (defun msb--make-keymap-menu (raw-menu) (let ((end (cons '(nil) 'menu-bar-select-buffer)) (mcount 0)) (mapcar - (function - (lambda (sub-menu) - (cond - ((eq 'separator sub-menu) - (list 'separator "---")) - (t - (let ((buffers (mapcar (function - (lambda (item) - (let ((string (car item)) - (buffer (cdr item))) - (cons (buffer-name buffer) - (cons string end))))) - (cdr sub-menu)))) - (append (list (incf mcount) (car sub-menu) - 'keymap (car sub-menu)) - (msb--split-menus buffers))))))) + (lambda (sub-menu) + (cond + ((eq 'separator sub-menu) + (list 'separator "--")) + (t + (let ((buffers (mapcar (lambda (item) + (cons (buffer-name (cdr item)) + (cons (car item) end))) + (cdr sub-menu)))) + (nconc (list (incf mcount) (car sub-menu) + 'keymap (car sub-menu)) + (msb--split-menus buffers)))))) raw-menu))) -(defun menu-bar-update-buffers (&optional arg) +(defun msb-menu-bar-update-buffers (&optional arg) + "A re-written version of `menu-bar-update-buffers'." ;; If user discards the Buffers item, play along. (when (and (lookup-key (current-global-map) [menu-bar buffer]) (or (not (fboundp 'frame-or-buffer-changed-p)) @@ -964,40 +1112,51 @@ variable `msb-menu-cond'." (nconc (list 'frame f-title '(nil) 'keymap f-title) (mapcar - (function - (lambda (frame) - (nconc - (list frame - (cdr (assq 'name - (frame-parameters frame))) - (cons nil nil)) - 'menu-bar-select-frame))) + (lambda (frame) + (nconc + (list (frame-parameter frame 'name) + (frame-parameter frame 'name) + (cons nil nil)) + 'menu-bar-select-frame)) frames))))) (define-key (current-global-map) [menu-bar buffer] (cons "Buffers" (if (and buffers-menu frames-menu) ;; Combine Frame and Buffers menus with separator between (nconc (list 'keymap "Buffers and Frames" frames-menu - (and msb-separator-diff '(separator "---"))) + (and msb-separator-diff '(separator "--"))) (cddr buffers-menu)) (or buffers-menu 'undefined))))))) -(when (and (boundp 'menu-bar-update-hook) - (not (fboundp 'frame-or-buffer-changed-p))) - (defvar msb--buffer-count 0) - (defun frame-or-buffer-changed-p () - (let ((count (length (buffer-list)))) - (when (/= count msb--buffer-count) - (setq msb--buffer-count count) - t)))) - -(unless (or (not (boundp 'menu-bar-update-hook)) - (memq 'menu-bar-update-buffers menu-bar-update-hook)) - (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers)) - -(and (fboundp 'mouse-buffer-menu) - (substitute-key-definition 'mouse-buffer-menu 'msb (current-global-map))) +;; Snarf current bindings of `mouse-buffer-menu' (normally +;; C-down-mouse-1). +(defvar msb-mode-map + (let ((map (make-sparse-keymap "Msb"))) + (define-key map [remap mouse-buffer-menu] 'msb) + map)) + +;;;###autoload +(define-minor-mode msb-mode + "Toggle Msb mode. +With arg, turn Msb mode on if and only if arg is positive. +This mode overrides the binding(s) of `mouse-buffer-menu' to provide a +different buffer menu using the function `msb'." + :global t + (if msb-mode + (progn + (add-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers) + (remove-hook 'menu-bar-update-hook 'menu-bar-update-buffers) + (msb-menu-bar-update-buffers t)) + (remove-hook 'menu-bar-update-hook 'msb-menu-bar-update-buffers) + (add-hook 'menu-bar-update-hook 'menu-bar-update-buffers) + (menu-bar-update-buffers t))) + +(defun msb-unload-hook () + (msb-mode 0)) +(add-hook 'msb-unload-hook 'msb-unload-hook) (provide 'msb) -(eval-after-load 'msb (run-hooks 'msb-after-load-hooks)) +(eval-after-load "msb" '(run-hooks 'msb-after-load-hook 'msb-after-load-hooks)) + +;;; arch-tag: 403f9e82-b92e-4e7a-a797-5d6d9b76da36 ;;; msb.el ends here