(eval-when-compile (require 'cl))
(defconst msb--few-menus
'(((and (boundp 'server-buffer-clients)
server-buffer-clients
'multi)
3030
"Clients (%d)")
((and msb-display-invisible-buffers-p
(msb-invisible-buffer-p)
'multi)
3090
"Invisible buffers (%d)")
((eq major-mode 'dired-mode)
2010
"Dired (%d)"
msb-dired-item-handler
msb-sort-by-directory)
((eq major-mode 'Man-mode)
4090
"Manuals (%d)")
((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 message-mode gnus-group-mode
gnus-article-mode score-mode gnus-browse-killed-mode)))
4010
"Mail (%d)")
((not buffer-file-name)
4099
"Buffers (%d)")
('no-multi
1099
"Files (%d)")))
(defconst msb--very-many-menus
'(((and (boundp 'server-buffer-clients)
server-buffer-clients
'multi)
1010
"Clients (%d)")
((and (boundp 'vc-mode) vc-mode 'multi)
1020
"Version Control (%d)")
((and buffer-file-name
(buffer-modified-p)
'multi)
1030
"Changed files (%d)")
((and (get-buffer-process (current-buffer))
'multi)
1040
"Processes (%d)")
((and msb-display-invisible-buffers-p
(msb-invisible-buffer-p)
'multi)
1090
"Invisible buffers (%d)")
((eq major-mode 'dired-mode)
2010
"Dired (%d)"
msb-dired-item-handler
msb-sort-by-directory)
((eq major-mode 'Man-mode)
5030
"Manuals (%d)")
((eq major-mode 'w3-mode)
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 message-mode gnus-group-mode
gnus-article-mode score-mode
gnus-browse-killed-mode)))
5010
"Mail (%d)")
((and (not buffer-file-name)
'no-multi)
5099
"Other non-file buffers (%d)")
((and (string-match "/\\.[^/]*$" buffer-file-name)
'multi)
3090
"Hidden Files (%d)")
((memq major-mode '(c-mode c++-mode))
3010
"C/C++ Files (%d)")
((eq major-mode 'emacs-lisp-mode)
3020
"Elisp Files (%d)")
((eq major-mode 'latex-mode)
3030
"LaTeX Files (%d)")
('no-multi
3099
"Other files (%d)")))
(defvar msb--many-menus msb--very-many-menus)
(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)
(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.
A value of 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."
: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.")
(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."
:type '(choice integer (const nil))
:set 'msb-custom-set
:group 'msb)
(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 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."
:type 'integer
:set 'msb-custom-set
:group 'msb)
(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)
(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)."
: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-horizontal-shift-function '(lambda () 0)
"*Function that specifies how many pixels to shift the top menu leftwards.")
(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."
:type 'boolean
:set 'msb-custom-set
:group 'msb)
(defvar msb-item-handling-function 'msb-item-handler
"*The appearance of a buffer menu.
The default function to call for handling the appearance of a menu
item. It should take to arguments, BUFFER and MAX-BUFFER-NAME-LENGTH,
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
information.")
(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-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)."
: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)
(defvar msb--last-buffer-menu nil)
(defvar msb--error nil)
(defun msb-item-handler (buffer &optional maxbuf)
"Create one string item, concerning BUFFER, for the buffer menu.
The item looks like:
*% <buffer-name>
The `*' appears only if the buffer is marked as modified.
The `%' appears only if the buffer is read-only.
Optional second argument MAXBUF is completely ignored."
(let ((name (buffer-name))
(modified (if (buffer-modified-p) "*" " "))
(read-only (if buffer-read-only "%" " ")))
(format "%s%s %s" modified read-only name)))
(eval-when-compile (require 'dired))
(defun msb--dired-directory ()
(cond ((stringp dired-directory)
(abbreviate-file-name (expand-file-name dired-directory)))
((consp dired-directory)
(abbreviate-file-name (expand-file-name (car dired-directory))))
(t
(error "Unknown type of `dired-directory' in buffer %s"
(buffer-name)))))
(defun msb-dired-item-handler (buffer &optional maxbuf)
"Create one string item, concerning a dired BUFFER, for the buffer menu.
The item looks like:
*% <buffer-name>
The `*' appears only if the buffer is marked as modified.
The `%' appears only if the buffer is read-only.
Optional second argument MAXBUF is completely ignored."
(let ((name (msb--dired-directory))
(modified (if (buffer-modified-p) "*" " "))
(read-only (if buffer-read-only "%" " ")))
(format "%s%s %s" modified read-only name)))
(defun msb-alon-item-handler (buffer maxbuf)
"Create one string item for the buffer menu.
The item looks like:
<buffer-name> *%# <file-name>
The `*' appears only if the buffer is marked as modified.
The `%' appears only if the buffer is read-only.
The `#' appears only version control file (SCCS/RCS)."
(format (format "%%%ds %%s%%s%%s %%s" maxbuf)
(buffer-name buffer)
(if (buffer-modified-p) "*" " ")
(if buffer-read-only "%" " ")
(if (and (boundp 'vc-mode) vc-mode) "#" " ")
(or buffer-file-name "")))
(defun msb-sort-by-name (item1 item2)
"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)
"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))))
(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
selects that window.
See the function `mouse-select-buffer' and the variable
`msb-menu-cond' for more information about how the menus are split."
(interactive "e")
(let ((old-window (selected-window))
(window (posn-window (event-start event)))
early-release)
(unless (framep window) (select-window window))
(setq early-release (not (sit-for 0.1 t)))
(let ((buffer (mouse-select-buffer event)))
(if buffer
(switch-to-buffer buffer)
(select-window old-window)))
(if (and early-release (memq 'down (event-modifiers last-input-event)))
(discard-input)))
nil)
(defun msb-invisible-buffer-p (&optional buffer)
"Return t if optional BUFFER is an \"invisible\" buffer.
If the argument is left out or nil, then the current buffer is considered."
(and (> (length (buffer-name buffer)) 0)
(eq ?\s (aref (buffer-name buffer) 0))))
(defun msb--strip-dir (dir)
"Strip one hierarchy level from the end of DIR."
(file-name-directory (directory-file-name dir)))
(defun msb--init-file-alist (list)
(let ((buffer-alist
(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))))))
(let ((dir nil)
(buffers nil))
(nconc
(apply
#'nconc
(mapcar (lambda (item)
(cond
((equal dir (car item))
(push (cdr item) buffers)
nil)
(t
(let ((result (and dir (cons dir buffers))))
(setq dir (car item))
(setq buffers (list (cdr item)))
(and result (list result))))))
buffer-alist))
(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))
(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-dir nil)
first rest dir buffers old-dir)
(setq first (car buffer-alist)
rest (cdr buffer-alist)
dir (car first)
buffers (cdr first))
(setq msb--choose-file-menu-list (copy-sequence rest))
(while rest
(let ((found-p nil)
(tmp-rest rest)
result
new-dir item)
(setq item (car tmp-rest))
(while (and tmp-rest
(<= (length buffers) max-clumped-together)
(>= (length (car item)) (length dir))
(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)
item (car tmp-rest)))
(cond
((> (length buffers) max-clumped-together)
(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)
(setq first (car rest)
rest (cdr rest)
dir (car first)
buffers (cdr first)))
(t
(when found-p
(setq top-found-p t)
(setq first (cons dir buffers)
rest tmp-rest))
(setq old-dir dir)
(setq dir (msb--strip-dir dir)
buffers (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)))))
(push (cons (msb--format-title top-found-p
(car first)
(length (cdr first)))
(cdr first))
final-list)
(setq top-found-p nil)
(setq first (car rest)
rest (cdr rest)
dir (car first)
buffers (cdr first)))))))
(when first
(push (cons (msb--format-title top-found-p
(car first)
(length (cdr first)))
(cdr first))
final-list))
(setq top-found-p nil)
(nreverse final-list)))
(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)))
(item-handler (if (and tmp-ih (fboundp tmp-ih))
tmp-ih
msb-item-handling-function))
(tmp-s (if (> (length menu-cond-elt) 4)
(nth 4 menu-cond-elt)
msb-item-sort-function))
(sorter (if (or (fboundp tmp-s)
(null tmp-s)
(eq tmp-s t))
tmp-s
msb-item-sort-function)))
(when (< (length menu-cond-elt) 3)
(error "Wrong format of msb-menu-cond"))
(when (and (> (length menu-cond-elt) 3)
(not (fboundp tmp-ih)))
(signal 'invalid-function (list tmp-ih)))
(when (and (> (length menu-cond-elt) 4)
tmp-s
(not (fboundp tmp-s))
(not (eq tmp-s t)))
(signal 'invalid-function (list tmp-s)))
(set list-symbol ())
(vector list-symbol (nth 0 menu-cond-elt) (nth 1 menu-cond-elt) (nth 2 menu-cond-elt) item-handler sorter) ))
(defsubst msb--collect (function-info-vector)
(let ((result nil)
(multi-flag nil)
function-info-list)
(setq function-info-list
(loop for fi
across function-info-vector
if (and (setq result
(eval (aref fi 1))) (not (and (eq result 'no-multi)
multi-flag))
(progn (when (eq result 'multi)
(setq multi-flag t))
t))
collect fi
until (and result
(not (eq result 'multi)))))
(when (and (not function-info-list)
(not result))
(error "No catch-all in msb-menu-cond!"))
function-info-list))
(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))) (set list-symbol
(cons (cons (funcall (aref function-info 4) buffer
max-buffer-name-length)
buffer)
(eval list-symbol)))))
(defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
"Select the appropriate menu for BUFFER."
(unless (and (not msb-display-invisible-buffers-p)
(msb-invisible-buffer-p buffer))
(condition-case nil
(save-excursion
(set-buffer buffer)
(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 "%s" msb--error))))))
(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)) (sort-key (aref function-info 2))) (when sort-key
(cons sort-key
(cons (format (aref function-info 3) (length buffer-list))
(cond
((null sorter)
buffer-list)
((eq sorter t)
(nreverse buffer-list))
(t
(sort buffer-list sorter))))))))))
(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)))
(most-recently-used
(loop with n = 0
for buffer in buffers
if (save-excursion
(set-buffer buffer)
(and (not (msb-invisible-buffer-p))
(not (eq major-mode 'dired-mode))))
collect (save-excursion
(set-buffer buffer)
(cons (funcall msb-item-handling-function
buffer
max-buffer-name-length)
buffer))
and do (incf n)
until (>= n msb-display-most-recently-used))))
(cons (if (stringp msb-most-recently-used-title)
(format msb-most-recently-used-title
(length most-recently-used))
(signal 'wrong-type-argument (list msb-most-recently-used-title)))
most-recently-used))))
(defun msb--create-buffer-menu-2 ()
(let ((max-buffer-name-length 0)
file-buffers
function-info-vector)
(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))))))
(setq function-info-vector
(apply (function vector)
(mapcar (function msb--create-function-info)
(append msb-menu-cond (msb--mode-menu-cond)))))
(dolist (buffer (buffer-list))
(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))))
(when file-buffers
(setq file-buffers
(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))))
(let* (menu
(most-recently-used
(msb--most-recently-used-menu max-buffer-name-length))
(others (nconc file-buffers
(loop for elt
across function-info-vector
for value = (msb--create-sort-item elt)
if value collect value))))
(setq menu
(mapcar 'cdr (msb--add-separators
(sort
(if (cdr most-recently-used)
(cons
(cons msb-most-recently-used-sort-key
most-recently-used)
others)
others)
(lambda (elt1 elt2)
(< (car elt1) (car elt2)))))))
(append
'(keymap "Select Buffer")
(msb--make-keymap-menu menu)
(when msb-separator-diff
(list (list 'separator "--")))
(list (cons 'toggle
(cons
(if msb-files-by-directory
"*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))))
(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))
(msb-menu-bar-update-buffers t))
(defun mouse-select-buffer (event)
"Pop up several menus of buffers, for selection with the mouse.
Returns the selected buffer or nil if no buffer is selected.
The way the buffers are split is conveniently handled with the
variable `msb-menu-cond'."
(when (or msb--error
(not msb--last-buffer-menu)
(not (fboundp 'frame-or-buffer-changed-p))
(frame-or-buffer-changed-p))
(setq msb--error nil)
(setq msb--last-buffer-menu (msb--create-buffer-menu)))
(let ((position event)
choice)
(when (and (fboundp 'posn-x-y)
(fboundp 'posn-window))
(let ((posX (car (posn-x-y (event-start event))))
(posY (cdr (posn-x-y (event-start event))))
(posWind (posn-window (event-start event))))
(setq posX (- posX (funcall msb-horizontal-shift-function))
position (list (list posX posY) posWind))))
(setq choice (x-popup-menu position msb--last-buffer-menu))
(cond
((eq (car choice) 'toggle)
(msb--toggle-menu-type)
(mouse-select-buffer event))
((and (numberp (car choice))
(null (cdr choice)))
(let ((msb--last-buffer-menu (nthcdr 2 (assq (car choice)
msb--last-buffer-menu))))
(mouse-select-buffer event)))
((while (numberp (car choice))
(setq choice (cdr choice))))
((and (stringp (car choice))
(null (cdr choice)))
(car choice))
((null choice)
choice)
(t
(error "Unknown form for buffer: %s" choice)))))
(defun msb--add-separators (sorted-list)
(if (or (not msb-separator-diff)
(not (numberp msb-separator-diff)))
sorted-list
(let ((last-key nil))
(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
((> (length list) msb-max-menu-items)
(let ((count 0)
sub-name
(tmp-list nil))
(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 (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 (nconc (list mcount sub-name 'keymap sub-name)
list)
result))
(nreverse result))))
(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
(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 msb-menu-bar-update-buffers (&optional arg)
"A re-written version of `menu-bar-update-buffers'."
(when (and (lookup-key (current-global-map) [menu-bar buffer])
(or (not (fboundp 'frame-or-buffer-changed-p))
(frame-or-buffer-changed-p)
arg))
(let ((frames (frame-list))
buffers-menu frames-menu)
(setq msb--last-buffer-menu (msb--create-buffer-menu))
(setq buffers-menu msb--last-buffer-menu)
(when (cdr frames)
(let* ((frame-length (length frames))
(f-title (format "Frames (%d)" frame-length)))
(when (and (integerp msb-max-menu-items)
(> msb-max-menu-items 1)
(> frame-length msb-max-menu-items))
(setcdr (nthcdr msb-max-menu-items frames) nil))
(setq frames-menu
(nconc
(list 'frame f-title '(nil) 'keymap f-title)
(mapcar
(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)
(nconc (list 'keymap "Buffers and Frames" frames-menu
(and msb-separator-diff '(separator "--")))
(cddr buffers-menu))
(or buffers-menu 'undefined)))))))
(defvar msb-mode-map
(let ((map (make-sparse-keymap "Msb")))
(define-key map [remap mouse-buffer-menu] 'msb)
map))
(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 :group 'msb
(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-hook 'msb-after-load-hooks))