Download
(provide 'buffer-stack)
(defgroup buffer-stack nil
"Smart movement through the buffer list."
:group 'editing
:prefix "buffer-stack-"
:link '(emacs-commentary-link :tag "Commentary" "buffer-stack.el")
:link '(emacs-library-link :tag "Lisp File" "buffer-stack.el"))
(defcustom buffer-stack-frame-local t
"Does each frame maintain a seperate buffer stack?
If you switch this off during a GNU Emacs session, the initial buffer
ordering might be strange."
:type 'boolean
:group 'buffer-stack)
(defcustom buffer-stack-quiet t
"No beeping."
:type 'boolean
:group 'buffer-stack)
(defcustom buffer-stack-show-position 'buffer-stack-show-position-number
"How do we display our position in the stack while switching?
\"as number\" prints something like \"BUFFER: 2/4\". \"as surrounding
buffers\" prints something like \"DOWN: *Next Buffer* ---- UP: *Last
Buffer*\". If you supply your own function, it should take two
arguments: the current index in the stack and the stack itself."
:type '(choice (const :tag "as number" buffer-stack-show-position-number)
(const :tag "as surrounding buffers" buffer-stack-show-position-buffers)
(function :tag "using my function")
(const :tag "don't show position" nil))
:group 'buffer-stack)
(defcustom buffer-stack-filter 'buffer-stack-filter-exclusive
"How do we filter the stack?
Exclusive means explicitly untracked buffers are hidden while all
others are shown. Inclusive means explicitly tracked buffers are shown
while all others are hidden. If you supply your own function, it
should take a buffer and return non-nil if that buffer is to be
included in the stack."
:type '(choice (const :tag "exclusive" buffer-stack-filter-exclusive)
(const :tag "inclusive" buffer-stack-filter-inclusive)
(function :tag "using my function"))
:group 'buffer-stack)
(defcustom buffer-stack-untracked
'("KILL" "*Compile-Log*" "*Compile-Log-Show*"
"*Group*" "*Completions*" "*Messages*")
"The list of buffer names to hide when switching through the stack.
This is used only with `buffer-stack-filter-exclusive', and is in
addition to permanently-hidden buffers which start with a space."
:type '(repeat string)
:group 'buffer-stack)
(defcustom buffer-stack-tracked nil
"The list of buffer names to show when switching through the stack.
This is used only with `buffer-stack-filter-inclusive'."
:type '(repeat string)
:group 'buffer-stack)
(defvar buffer-stack-last-frame nil
"The frame we're moving in.")
(defvar buffer-stack-last-buffer nil
"The buffer we last put on top.")
(defvar buffer-stack-last-filter nil
"Last filter used for switching.")
(defvar buffer-stack-index nil
"Our position in the stack.")
(defvar buffer-stack nil
"Stack of buffers in order, from most recent to least.")
(defun buffer-stack-track ()
"Track the current buffer.
Remove it from the untracked list, and add it to the tracked list."
(interactive)
(setq buffer-stack-untracked (delete (buffer-name (current-buffer)) buffer-stack-untracked))
(add-to-list 'buffer-stack-tracked (buffer-name (current-buffer))))
(defun buffer-stack-untrack ()
"Untrack the current buffer.
Remove it from the tracked list, and add it to the untracked list."
(interactive)
(add-to-list 'buffer-stack-untracked (buffer-name (current-buffer)))
(setq buffer-stack-tracked (delete (buffer-name (current-buffer)) buffer-stack-tracked)))
(defun buffer-stack-down ()
"Move down in the buffer stack.
Down is the direction of less-recent buffers."
(interactive)
(buffer-stack-move 1)
(buffer-stack-show-position))
(defun buffer-stack-up ()
"Move up in the buffer stack.
If you were switching, up is where you came from."
(interactive)
(buffer-stack-move -1)
(buffer-stack-show-position))
(defun buffer-stack-bury-and-kill ()
"Bury the current buffer, then kill it.
Civilized people kill BEFORE burying, but who's civilized here? This
command counts as switching."
(interactive)
(let ((buffer (current-buffer)))
(buffer-stack-bury)
(kill-buffer buffer)
(setq buffer-stack (buffer-stack-clean buffer-stack))
(when (null buffer-stack)
(setq buffer-stack (list (current-buffer)))
(setq buffer-stack-last-buffer (current-buffer)))
(buffer-stack-show-position)))
(defun buffer-stack-bury ()
"Bury the current buffer and move to the next in the stack.
This command counts as switching, meaning you can do it while
switching buffers and then continue switching buffers."
(interactive)
(if (and (buffer-stack-switching-p) (>= buffer-stack-index (- (length buffer-stack) 1)))
(progn
(or buffer-stack-quiet
(beep))
(message "Tried to bury bottom-most buffer!")
(unless (= (length buffer-stack) 1)
(buffer-stack-move -1)))
(let ((buffer (current-buffer)))
(when (buffer-stack-switching-p)
(buffer-stack-assert-not-empty)
(setq buffer-stack (delq buffer buffer-stack))
(when (buffer-stack-tracked-p buffer)
(setq buffer-stack (nconc buffer-stack (list buffer)))))
(buffer-stack-bury-buffer buffer)
(buffer-stack-move 0)
(if (= (length buffer-stack) 1)
(message "Tried to bury bottom-most buffer!")
(buffer-stack-show-position)))))
(defun buffer-stack-move (direction)
"Move through the stack by one buffer.
This is THE switching command; all other motions are based on this."
(setq this-command 'buffer-stack-move)
(unless (buffer-stack-switching-p)
(setq buffer-stack-index 0)
(buffer-stack-rebuild)
(setq buffer-stack-last-frame (selected-frame))
(setq buffer-stack-last-filter buffer-stack-filter)
(unless (buffer-stack-tracked-p (current-buffer))
(setq buffer-stack (cons (current-buffer) buffer-stack))))
(buffer-stack-assert-not-empty)
(let ((max-index (- (length buffer-stack) 1))
(buffer (current-buffer)))
(if (= max-index 0)
(or buffer-stack-quiet
(beep))
(if (> direction 0)
(incf buffer-stack-index)
(if (< direction 0)
(decf buffer-stack-index)))
(if (< buffer-stack-index 0)
(progn (setq buffer-stack-index max-index)
(setq buffer (nth buffer-stack-index buffer-stack))
(or buffer-stack-quiet
(beep)))
(if (> buffer-stack-index max-index)
(progn (setq buffer-stack-index 0)
(buffer-stack-bury-buffer (current-buffer))
(setq buffer (first buffer-stack))
(or buffer-stack-quiet
(beep)))
(setq buffer (nth buffer-stack-index buffer-stack))
(unless (eq (current-buffer) buffer)
(buffer-stack-bury-buffer (current-buffer) buffer)))))
(switch-to-buffer buffer)
(setq buffer-stack-last-buffer buffer)))
(defun buffer-stack-bury-buffer (buffer &optional before)
"Emulate xemacs's bury-buffer for GNU Emacs."
(if (featurep 'xemacs) (bury-buffer buffer before)
(if buffer-stack-frame-local
(let* ((frame (selected-frame))
(new-list (buffer-list frame))
(rest new-list))
(setq new-list (delq buffer new-list))
(if (null new-list)
(setq new-list (list buffer))
(if (null before)
(setq new-list (nconc new-list (list buffer)))
(if (eq before (car new-list))
(setq new-list (cons buffer new-list))
(while (not (or (null (cdr rest)) (eq (cadr rest) before)))
(setq rest (cdr rest)))
(setcdr rest (cons buffer (cdr rest)))
)))
(modify-frame-parameters frame (list (cons 'buffer-list new-list))))
(dolist (b (buffer-list nil))
(when (eq b before)
(bury-buffer buffer))
(unless (eq b buffer)
(bury-buffer b))))))
(defun buffer-stack-rebuild ()
"Create `buffer-stack' from the buffer list."
(setq buffer-stack (buffer-stack-clean (buffer-list (buffer-stack-frame)))))
(defun buffer-stack-clean (buffer-list)
"Remove untracked buffers from a list by side effect."
(let ((rest buffer-list)
buffer
last)
(while (not (null rest))
(setq buffer (car rest))
(if (buffer-stack-tracked-p buffer)
(setq last rest)
(if last
(setcdr last (cdr rest))
(setq buffer-list (cdr rest))))
(setq rest (cdr rest)))
buffer-list))
(defun buffer-stack-switching-p ()
"Are we switching buffers?"
(and (eq last-command 'buffer-stack-move)
(eq buffer-stack-last-frame (selected-frame))
(eq buffer-stack-last-buffer (current-buffer))
(eq buffer-stack-last-filter buffer-stack-filter)))
(defun buffer-stack-frame ()
(if buffer-stack-frame-local
(selected-frame)
(if (featurep 'xemacs)
t
nil)))
(defun buffer-stack-assert-not-empty ()
(if (null buffer-stack)
(error "The buffer stack is empty! Please report this as a bug.")))
(defun buffer-stack-show-position ()
"Print the current position."
(buffer-stack-assert-not-empty)
(unless (null buffer-stack-show-position)
(funcall buffer-stack-show-position buffer-stack-index buffer-stack)))
(defun buffer-stack-show-position-number (buffer-stack-index buffer-stack)
"Show position like this: BUFFER 1/3
That's number/total."
(message (concat "BUFFER: "
(prin1-to-string (+ buffer-stack-index 1))
"/"
(prin1-to-string (length buffer-stack)))))
(defun buffer-stack-show-position-buffers (buffer-stack-index buffer-stack)
"Show position like this: DOWN: *Next Buffer* ---- UP: *Previous Buffer*"
(let (up-buffer-index
down-buffer-index
(max-index (- (length buffer-stack) 1)))
(if (eq buffer-stack-index 0)
(setq up-buffer-index max-index)
(setq up-buffer-index (- buffer-stack-index 1)))
(if (eq buffer-stack-index max-index)
(setq down-buffer-index 0)
(setq down-buffer-index (+ buffer-stack-index 1)))
(message (concat "DOWN: "
(buffer-name (nth down-buffer-index buffer-stack))
" ---- " "UP: "
(buffer-name (nth up-buffer-index buffer-stack))))
))
(defun buffer-stack-tracked-p (buffer)
"Is this buffer tracked?"
(funcall buffer-stack-filter buffer))
(defun buffer-stack-filter-exclusive (buffer)
"Non-nil if buffer is not in buffer-stack-untracked or a 'hidden' buffer."
(let ((name (buffer-name buffer)))
(not (or (null name)
(char-equal ? (string-to-char name))
(member name buffer-stack-untracked)))))
(defun buffer-stack-filter-inclusive (buffer)
"Non-nil if buffer is in buffer-stack-tracked."
(member (buffer-name buffer) buffer-stack-tracked))