9da3ffee41
This is a massive diff that I had to do in a hurry - when leaving Urbint. I'm pretty sure that most of these are updating Emacs packages, but I'm not positive.
428 lines
16 KiB
EmacsLisp
428 lines
16 KiB
EmacsLisp
;;; tracking.el --- Buffer modification tracking
|
|
|
|
;; Copyright (C) 2006, 2012 - 2015 Jorgen Schaefer
|
|
|
|
;; Author: Jorgen Schaefer <forcer@forcix.cx>
|
|
;; URL: https://github.com/jorgenschaefer/circe/wiki/Tracking
|
|
|
|
;; This program 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 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program 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, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; tracking.el is a library for other Emacs Lisp programs not useful
|
|
;; by itself.
|
|
|
|
;; The library provides a way to globally register buffers as being
|
|
;; modified and scheduled for user review. The user can cycle through
|
|
;; the buffers using C-c C-SPC. This is especially useful for buffers
|
|
;; that interact with external sources, such as chat clients and
|
|
;; similar programs.
|
|
|
|
;;; Code:
|
|
|
|
(require 'easy-mmode)
|
|
(require 'shorten)
|
|
(require 'cl-lib)
|
|
|
|
;;; User customization
|
|
(defgroup tracking nil
|
|
"Tracking of buffer activities."
|
|
:prefix "tracking-"
|
|
:group 'applications)
|
|
|
|
(defcustom tracking-shorten-buffer-names-p t
|
|
"Whether to shorten buffer names in the mode line.
|
|
A non-nil value will cause tracked buffer names to be shortened
|
|
as much as possible to stay unambiguous when displaying them in
|
|
the mode line."
|
|
:type 'boolean
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-frame-behavior 'visible
|
|
"How to deal with frams to determine visibility of buffers.
|
|
This is passed as the second argument to `get-buffer-window',
|
|
see there for further explanation."
|
|
:type '(choice (const :tag "All visible frames" visible)
|
|
(const :tag "Visible and iconified frames" 0)
|
|
(const :tag "All frames" t)
|
|
(const :tag "Selected frame only" nil))
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-position 'before-modes
|
|
"Where tracked buffers should appear in the mode line.
|
|
|
|
'before-modes
|
|
Before the mode indicators
|
|
'after-modes
|
|
After the mode indicators
|
|
'end
|
|
At the end of the mode line"
|
|
:type '(choice (const :tag "Before the Mode Indicators" before-modes)
|
|
(const :tag "Afterthe Mode Indicators" after-modes)
|
|
(const :tag "At the End of the Mode Line" end))
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-faces-priorities nil
|
|
"A list of faces which should be shown by tracking in the mode line.
|
|
The first face found in this list is used."
|
|
:type '(repeat face)
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-ignored-buffers nil
|
|
"A list of buffers that are never tracked.
|
|
Each element of this list has one of the following forms:
|
|
|
|
regexp - Any buffer matching won't be tracked.
|
|
function - Any buffer matching won't be tracked.
|
|
(regexp faces ...) - Any buffer matching won't be tracked,
|
|
unless it has a face in FACES ... associated with it.
|
|
If no faces are given, `tracking-faces-priorities' is
|
|
used.
|
|
(function faces ...) - As per above, but with a function
|
|
as predicate instead of a regexp."
|
|
:type '(repeat (choice regexp
|
|
function
|
|
(list (choice regexp function)
|
|
(repeat face))))
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-most-recent-first nil
|
|
"When non-nil, newly tracked buffers will go to the front of the
|
|
list, rather than to the end."
|
|
:type 'boolean
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-sort-faces-first nil
|
|
"When non-nil, tracked buffers with any highlight face will go to
|
|
the front of the tracking list.
|
|
|
|
See `tracking-most-recent-first' for whether they are appended at the
|
|
front or the back of the highlighted buffers."
|
|
:type 'boolean
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-buffer-added-hook nil
|
|
"Hook run when a buffer has some activity.
|
|
|
|
The functions are run in the context of the buffer.
|
|
|
|
This can also happen when the buffer is already tracked. Check if the
|
|
buffer name is in `tracking-buffers' if you want to see if it was
|
|
added before."
|
|
:type 'hook
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-buffer-removed-hook nil
|
|
"Hook run when a buffer becomes active and is removed.
|
|
|
|
The functions are run in the context of the buffer."
|
|
:type 'hook
|
|
:group 'tracking)
|
|
|
|
(defcustom tracking-max-mode-line-entries nil
|
|
"Maximum number of buffers shown in the mode-line.
|
|
|
|
If set to nil, all buffers will be shown."
|
|
:type '(choice (const :tag "All" nil)
|
|
(integer :tag "Maximum"))
|
|
:group 'tracking)
|
|
|
|
;;; Internal variables
|
|
(defvar tracking-buffers nil
|
|
"The list of currently tracked buffers.")
|
|
|
|
(defvar tracking-mode-line-buffers ""
|
|
"The entry to the mode line.")
|
|
(put 'tracking-mode-line-buffers 'risky-local-variable t)
|
|
|
|
(defvar tracking-start-buffer nil
|
|
"The buffer we started from when cycling through the active buffers.")
|
|
|
|
(defvar tracking-last-buffer nil
|
|
"The buffer we last switched to with `tracking-next-buffer'.
|
|
When this is not the current buffer when we continue switching, a
|
|
new `tracking-start-buffer' is created.")
|
|
|
|
(defvar tracking-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "C-c C-SPC") 'tracking-next-buffer)
|
|
(define-key map (kbd "C-c C-@") 'tracking-next-buffer)
|
|
map)
|
|
"The keymap used for tracking mode.")
|
|
|
|
;;;###autoload
|
|
(define-minor-mode tracking-mode
|
|
"Allow cycling through modified buffers.
|
|
This mode in itself does not track buffer modification, but
|
|
provides an API for programs to add buffers as modified (using
|
|
`tracking-add-buffer').
|
|
|
|
Once this mode is active, modified buffers are shown in the mode
|
|
line. The user can cycle through them using
|
|
\\[tracking-next-buffer]."
|
|
:group 'tracking
|
|
:global t
|
|
(cond
|
|
(tracking-mode
|
|
(cond
|
|
((eq tracking-position 'before-modes)
|
|
(let ((head nil)
|
|
(tail (default-value 'mode-line-format)))
|
|
(when (not (memq 'tracking-mode-line-buffers tail))
|
|
(catch 'return
|
|
(while tail
|
|
(if (not (eq (car tail)
|
|
'mode-line-modes))
|
|
(setq head (cons (car tail)
|
|
head)
|
|
tail (cdr tail))
|
|
(setq-default mode-line-format
|
|
(append (reverse head)
|
|
'(tracking-mode-line-buffers)
|
|
tail))
|
|
(throw 'return t)))))))
|
|
((eq tracking-position 'after-modes)
|
|
(add-to-list 'mode-line-misc-info
|
|
'tracking-mode-line-buffers))
|
|
((eq tracking-position 'end)
|
|
(add-to-list 'mode-line-misc-info
|
|
'tracking-mode-line-buffers
|
|
t))
|
|
(t
|
|
(error "Invalid value for `tracking-position' (%s)" tracking-position)))
|
|
(add-hook 'window-configuration-change-hook
|
|
'tracking-remove-visible-buffers))
|
|
(t
|
|
(setq mode-line-misc-info (delq 'tracking-mode-line-buffers
|
|
mode-line-misc-info))
|
|
(setq-default mode-line-format (delq 'tracking-mode-line-buffers
|
|
(default-value 'mode-line-format)))
|
|
(remove-hook 'window-configuration-change-hook
|
|
'tracking-remove-visible-buffers))))
|
|
|
|
;;;###autoload
|
|
(defun tracking-add-buffer (buffer &optional faces)
|
|
"Add BUFFER as being modified with FACES.
|
|
This does check whether BUFFER is currently visible.
|
|
|
|
If FACES is given, it lists the faces that might be appropriate
|
|
for BUFFER in the mode line. The highest-priority face of these
|
|
and the current face of the buffer, if any, is used. Priority is
|
|
decided according to `tracking-faces-priorities'.
|
|
When `tracking-sort-faces-first' is non-nil, all buffers with any
|
|
face set will be stable-sorted before any buffers with no face set."
|
|
(when (and (not (get-buffer-window buffer tracking-frame-behavior))
|
|
(not (tracking-ignored-p buffer faces)))
|
|
(with-current-buffer buffer
|
|
(run-hooks 'tracking-buffer-added-hook))
|
|
(let* ((entry (member (buffer-name buffer)
|
|
tracking-buffers)))
|
|
(if entry
|
|
(setcar entry (tracking-faces-merge (car entry)
|
|
faces))
|
|
(setq tracking-buffers
|
|
(if tracking-most-recent-first
|
|
(cons (tracking-faces-merge (buffer-name buffer)
|
|
faces)
|
|
tracking-buffers)
|
|
(nconc tracking-buffers
|
|
(list (tracking-faces-merge (buffer-name buffer)
|
|
faces)))))))
|
|
(when tracking-sort-faces-first
|
|
(let ((with-any-face (cl-remove-if-not
|
|
(lambda (str) (get-text-property 0 'face str))
|
|
tracking-buffers))
|
|
(with-no-face (cl-remove-if
|
|
(lambda (str) (get-text-property 0 'face str))
|
|
tracking-buffers)))
|
|
(setq tracking-buffers (nconc with-any-face with-no-face))))
|
|
(setq tracking-mode-line-buffers (tracking-status))
|
|
(force-mode-line-update t)
|
|
))
|
|
|
|
;;;###autoload
|
|
(defun tracking-remove-buffer (buffer)
|
|
"Remove BUFFER from being tracked."
|
|
(when (member (buffer-name buffer)
|
|
tracking-buffers)
|
|
(with-current-buffer buffer
|
|
(run-hooks 'tracking-buffer-removed-hook)))
|
|
(setq tracking-buffers (delete (buffer-name buffer)
|
|
tracking-buffers))
|
|
(setq tracking-mode-line-buffers (tracking-status))
|
|
(sit-for 0) ;; Update mode line
|
|
)
|
|
|
|
;;;###autoload
|
|
(defun tracking-next-buffer ()
|
|
"Switch to the next active buffer."
|
|
(interactive)
|
|
(cond
|
|
((and (not tracking-buffers)
|
|
tracking-start-buffer)
|
|
(let ((buf tracking-start-buffer))
|
|
(setq tracking-start-buffer nil)
|
|
(if (buffer-live-p buf)
|
|
(switch-to-buffer buf)
|
|
(message "Original buffer does not exist anymore")
|
|
(ding))))
|
|
((not tracking-buffers)
|
|
nil)
|
|
(t
|
|
(when (not (eq tracking-last-buffer
|
|
(current-buffer)))
|
|
(setq tracking-start-buffer (current-buffer)))
|
|
(let ((new (car tracking-buffers)))
|
|
(when (buffer-live-p (get-buffer new))
|
|
(with-current-buffer new
|
|
(run-hooks 'tracking-buffer-removed-hook)))
|
|
(setq tracking-buffers (cdr tracking-buffers)
|
|
tracking-mode-line-buffers (tracking-status))
|
|
(if (buffer-live-p (get-buffer new))
|
|
(switch-to-buffer new)
|
|
(message "Buffer %s does not exist anymore" new)
|
|
(ding)
|
|
(setq tracking-mode-line-buffers (tracking-status))))
|
|
(setq tracking-last-buffer (current-buffer))
|
|
;; Update mode line. See `force-mode-line-update' for the idea for
|
|
;; this code. Using `sit-for' can be quite inefficient for larger
|
|
;; buffers.
|
|
(dolist (w (window-list))
|
|
(with-current-buffer (window-buffer w)))
|
|
)))
|
|
|
|
;;;###autoload
|
|
(defun tracking-previous-buffer ()
|
|
"Switch to the last active buffer."
|
|
(interactive)
|
|
(when tracking-buffers
|
|
(switch-to-buffer (car (last tracking-buffers)))))
|
|
|
|
(defun tracking-ignored-p (buffer faces)
|
|
"Return non-nil when BUFFER with FACES shouldn't be tracked.
|
|
This uses `tracking-ignored-buffers'. Actual returned value is
|
|
the entry from tracking-ignored-buffers that causes this buffer
|
|
to be ignored."
|
|
(catch 'return
|
|
(let ((buffer-name (buffer-name buffer)))
|
|
(dolist (entry tracking-ignored-buffers)
|
|
(cond
|
|
((stringp entry)
|
|
(and (string-match entry buffer-name)
|
|
(throw 'return entry)))
|
|
((functionp entry)
|
|
(and (funcall entry buffer-name)
|
|
(throw 'return entry)))
|
|
((or (and (stringp (car entry))
|
|
(string-match (car entry) buffer-name))
|
|
(and (functionp (car entry))
|
|
(funcall (car entry) buffer-name)))
|
|
(when (not (tracking-any-in (or (cdr entry)
|
|
tracking-faces-priorities)
|
|
faces))
|
|
(throw 'return entry))))))
|
|
nil))
|
|
|
|
(defun tracking-status ()
|
|
"Return the current track status.
|
|
|
|
This returns a list suitable for `mode-line-format'.
|
|
If `tracking-max-mode-line-entries' is a positive integer,
|
|
only return that many entries, ending with '+n'."
|
|
(if (not tracking-buffers)
|
|
""
|
|
(let* ((buffer-names (cl-remove-if-not #'get-buffer tracking-buffers))
|
|
(shortened-names (tracking-shorten tracking-buffers))
|
|
(result (list " ["))
|
|
(i 0))
|
|
(cl-block exit
|
|
(while buffer-names
|
|
(push `(:propertize
|
|
,(car shortened-names)
|
|
face ,(get-text-property 0 'face (car buffer-names))
|
|
keymap ,(let ((map (make-sparse-keymap)))
|
|
(define-key map [mode-line down-mouse-1]
|
|
`(lambda ()
|
|
(interactive)
|
|
(pop-to-buffer ,(car buffer-names))))
|
|
map)
|
|
mouse-face mode-line-highlight
|
|
help-echo ,(format (concat "New activity in %s\n"
|
|
"mouse-1: pop to the buffer")
|
|
(car buffer-names)))
|
|
result)
|
|
(cl-incf i)
|
|
(setq buffer-names (cdr buffer-names)
|
|
shortened-names (cdr shortened-names))
|
|
(when (and tracking-max-mode-line-entries
|
|
buffer-names
|
|
(>= i tracking-max-mode-line-entries))
|
|
(push (concat " +" (number-to-string (length buffer-names))) result)
|
|
(cl-return-from exit))
|
|
(when buffer-names
|
|
(push "," result))))
|
|
(push "] " result)
|
|
(nreverse result))))
|
|
|
|
(defun tracking-remove-visible-buffers ()
|
|
"Remove visible buffers from the tracked buffers.
|
|
This is usually called via `window-configuration-changed-hook'."
|
|
(interactive)
|
|
(dolist (buffer-name tracking-buffers)
|
|
(let ((buffer (get-buffer buffer-name)))
|
|
(cond
|
|
((not buffer)
|
|
(setq tracking-buffers (delete buffer-name tracking-buffers))
|
|
(setq tracking-mode-line-buffers (tracking-status))
|
|
(sit-for 0))
|
|
((get-buffer-window buffer tracking-frame-behavior)
|
|
(tracking-remove-buffer buffer))))))
|
|
|
|
;;; Helper functions
|
|
(defun tracking-shorten (buffers)
|
|
"Shorten BUFFERS according to `tracking-shorten-buffer-names-p'."
|
|
(if tracking-shorten-buffer-names-p
|
|
(let ((all (shorten-strings (mapcar #'buffer-name (buffer-list)))))
|
|
(mapcar (lambda (buffer)
|
|
(let ((short (cdr (assoc buffer all))))
|
|
(set-text-properties
|
|
0 (length short)
|
|
(text-properties-at 0 buffer)
|
|
short)
|
|
short))
|
|
buffers))
|
|
buffers))
|
|
|
|
(defun tracking-any-in (lista listb)
|
|
"Return non-nil when any element in LISTA is in LISTB"
|
|
(catch 'return
|
|
(dolist (entry lista)
|
|
(when (memq entry listb)
|
|
(throw 'return t)))
|
|
nil))
|
|
|
|
(defun tracking-faces-merge (string faces)
|
|
"Merge faces into string, adhering to `tracking-faces-priorities'.
|
|
This returns STRING with the new face."
|
|
(let ((faces (cons (get-text-property 0 'face string)
|
|
faces)))
|
|
(catch 'return
|
|
(dolist (candidate tracking-faces-priorities)
|
|
(when (memq candidate faces)
|
|
(throw 'return
|
|
(propertize string 'face candidate))))
|
|
string)))
|
|
|
|
(provide 'tracking)
|
|
;;; tracking.el ends here
|