Download
(eval-when-compile (require 'cl))
(require 'browse-kill-ring)
(require 'second-sel nil t)
(defcustom browse-kill-ring-yank-commands (if (boundp 'secondary-selection-yank-commands)
secondary-selection-yank-commands
'(yank icicle-yank-maybe-completing))
"*Commands that yank.
Used by `yank-pop' to tell whether the previous command was a yank command.
Used only if `browse-kill-ring-default-keybindings' has been called,
so `yank-pop' is advised."
:type '(repeat (restricted-sexp :tag "Command that yanks text"
:match-alternatives (symbolp commandp) :value ignore))
:group 'browse-kill-ring :group 'killing)
(defcustom browse-kill-ring-alternative-yank-commands
(and (boundp 'secondary-selection-yank-secondary-commands)
secondary-selection-yank-secondary-commands)
"*Commands that yank using the alternative selection ring.
Used by `browse-kill-ring-setup' to tell whether the previous command
yanked from `browse-kill-ring-alternative-ring'."
:type '(repeat (restricted-sexp :match-alternatives (symbolp commandp) :value ignore))
:group 'browse-kill-ring :group 'killing)
(defcustom browse-kill-ring-alternative-ring
(and (boundp 'secondary-selection-ring)
'secondary-selection-ring)
"*Selection ring to use as an alternative to `kill-ring'.
A value of nil means there is no alternative selection ring; that is,
`kill-ring' is used always."
:type '(restricted-sexp :tag "Selection ring variable"
:match-alternatives (symbolp boundp) :value ignore)
:group 'browse-kill-ring :group 'killing)
(defcustom browse-kill-ring-alternative-push-function
(and (boundp 'secondary-selection-ring)
'add-secondary-to-ring)
"*Function that adds item to the front of alternative selection ring.
This is analogous to `kill-new' for the alternative ring.
It must accept the same same arguments as `kill-new'."
:type 'function
:group 'browse-kill-ring :group 'killing)
(defvar browse-kill-ring-current-ring 'kill-ring
"Symbol whose value is the current selection ring for `browse-kill-ring'.")
(defconst browse-kill-ring-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<tab>") 'browse-kill-ring-forward)
(define-key map [(control ?i)] 'browse-kill-ring-forward)
(define-key map (kbd "<S-tab>") 'browse-kill-ring-previous)
(define-key map (kbd "RET") 'browse-kill-ring-insert-and-quit)
(define-key map [(mouse-2)] 'browse-kill-ring-mouse-insert)
(define-key map (kbd "?") 'describe-mode)
(define-key map (kbd "1") 'browse-kill-ring-insert-and-move)
(define-key map (kbd "a") 'browse-kill-ring-append-insert)
(define-key map (kbd "b") 'browse-kill-ring-prepend-insert)
(define-key map (kbd "c") 'browse-kill-ring-copy-to-other-ring)
(define-key map (kbd "d") 'browse-kill-ring-delete)
(define-key map (kbd "e") 'browse-kill-ring-edit)
(define-key map (kbd "g") 'browse-kill-ring-update)
(define-key map (kbd "h") 'describe-mode)
(define-key map (kbd "i") 'browse-kill-ring-insert)
(define-key map (kbd "l") 'browse-kill-ring-occur)
(define-key map (kbd "n") 'browse-kill-ring-forward)
(define-key map (kbd "o") 'browse-kill-ring-switch-to-other-kill-ring)
(define-key map (kbd "p") 'browse-kill-ring-previous)
(define-key map (kbd "q") 'browse-kill-ring-quit)
(define-key map (kbd "r") 'browse-kill-ring-search-backward)
(define-key map (kbd "s") 'browse-kill-ring-search-forward)
(define-key map (kbd "t") 'toggle-browse-kill-ring-display-style)
(define-key map (kbd "u") 'browse-kill-ring-insert-move-and-quit)
(define-key map (kbd "U") 'browse-kill-ring-undo-other-window)
(define-key map (kbd "x") 'browse-kill-ring-insert-and-delete)
(define-key map (kbd "y") 'browse-kill-ring-insert)
map)
"Keymap for `browse-kill-ring-mode'.")
(defun browse-kill-ring-current-ring ()
"Current selection ring (the symbol whose value is the ring).
When in a selection-ring buffer, update variable
`browse-kill-ring-current-ring'. Return its value, in any case.
Use this instead of the variable, because the user might have switched
to a window showing the buffer for the other ring."
(if (not (eq major-mode 'browse-kill-ring-mode))
browse-kill-ring-current-ring
(setq browse-kill-ring-current-ring
(if (or (not browse-kill-ring-alternative-ring)
(string= (buffer-name) "*Selection Ring: `kill-ring'*"))
'kill-ring
browse-kill-ring-alternative-ring))))
(when (and (fboundp 'cl-puthash) (not (fboundp 'puthash)))
(defalias 'puthash 'cl-puthash))
(if (fboundp 'puthash)
(defun browse-kill-ring-remove-dups (sequence &optional test)
"Copy of SEQUENCE with duplicate elements removed.
Optional arg TEST is the test function. If nil, test with `equal'.
See `make-hash-table' for possible values of TEST."
(setq test (or test #'equal))
(let ((htable (make-hash-table :test test)))
(loop for elt in sequence
unless (gethash elt htable)
do (puthash elt elt htable)
finally return (loop for i being the hash-values in htable collect i))))
(defun browse-kill-ring-remove-dups (list &optional use-eq)
"Copy of LIST with duplicate elements removed.
Test using `equal' by default, or `eq' if optional USE-EQ is non-nil."
(let ((tail list)
new)
(while tail
(unless (if use-eq (memq (car tail) new) (member (car tail) new))
(push (car tail) new))
(pop tail))
(nreverse new))))
(when (fboundp 'add-secondary-to-ring)
(defadvice add-secondary-to-ring (around bkr-no-second-sel-new-dups)
"Advice for not adding duplicate elements to the secondary selection ring.
Even after being \"activated\", this advice will modify the behavior
of `add-secondary-to-ring' only if `browse-kill-ring-no-duplicates' is
non-nil."
(when browse-kill-ring-no-duplicates
(setq add-secondary-to-ring (delete (ad-get-arg 0) add-secondary-to-ring)))
ad-do-it))
(defun browse-kill-ring-target-overlay-at (position)
"Return overlay at POSITION that has property `browse-kill-ring-target'.
If no such overlay, raise an error."
(let ((ovs (overlays-at (point))))
(catch 'browse-kill-ring-target-overlay-at
(dolist (ov ovs)
(when (overlay-get ov 'browse-kill-ring-target)
(throw 'browse-kill-ring-target-overlay-at ov)))
(error "No selection-ring item here"))))
(defun browse-kill-ring-delete ()
"Remove all occurrences of selection at point from current selection ring."
(interactive)
(forward-line 0)
(unwind-protect
(let* ((ov (browse-kill-ring-target-overlay-at (point)))
(target (overlay-get ov 'browse-kill-ring-target)))
(setq buffer-read-only nil)
(delete-region (overlay-start ov) (1+ (overlay-end ov)))
(set browse-kill-ring-current-ring
(delete target (symbol-value (browse-kill-ring-current-ring))))
(when (get-text-property (point) 'browse-kill-ring-extra)
(let ((prev (previous-single-property-change (point) 'browse-kill-ring-extra))
(next (next-single-property-change (point) 'browse-kill-ring-extra)))
(when prev (incf prev))
(when next (incf next))
(delete-region (or prev (point-min)) (or next (point-max))))))
(setq buffer-read-only t))
(browse-kill-ring-resize-window)
(browse-kill-ring-forward 0))
(defun browse-kill-ring-current-string (buffer position)
"Selection entry in BUFFER that is nearest POSITION."
(with-current-buffer buffer
(save-excursion
(goto-char position)
(forward-line 0)
(overlay-get (browse-kill-ring-target-overlay-at (point)) 'browse-kill-ring-target))))
(defun browse-kill-ring-do-insert (bkr-buf sel-pos &optional append/prepend)
"Insert the selection that is at position SEL-POS in buffer BKR-BUF.
BKR-BUF is a selection-ring buffer, with a list of selections.
Insert the selection at point unless optional arg APPEND/PREPEND is:
`append' - insert at eob, not at point
`prepend' - insert at bob, not at point"
(unless (window-live-p browse-kill-ring-original-window)
(error "Window `%s' was deleted. Use `browse-kill-ring' again"
browse-kill-ring-original-window))
(let ((sel-string (browse-kill-ring-current-string bkr-buf sel-pos)))
(with-current-buffer (window-buffer browse-kill-ring-original-window)
(save-excursion
(let ((yank-excluded-properties (and browse-kill-ring-depropertize t))
(insert-pos (case append/prepend
(append (point-max))
(prepend (point-min))
(t (point)))))
(goto-char insert-pos)
(when (and delete-selection-mode (not buffer-read-only) transient-mark-mode mark-active
(not (memq append/prepend '(append prepend))))
(delete-active-region))
(insert (if browse-kill-ring-depropertize
(browse-kill-ring-depropertize-string sel-string)
sel-string))
(set-window-point browse-kill-ring-original-window (point))
(when browse-kill-ring-highlight-inserted-item
(let ((ov (make-overlay insert-pos (point))))
(overlay-put ov 'face 'highlight)
(sit-for 0.5)
(delete-overlay ov))))))))
(defun browse-kill-ring-do-prepend-insert (bkr-buf sel-pos)
"`browse-kill-ring-do-insert', with insertion at bob."
(browse-kill-ring-do-insert bkr-buf sel-pos 'prepend))
(defun browse-kill-ring-do-append-insert (bkr-buf sel-pos)
"`browse-kill-ring-do-insert', with insertion at eob."
(browse-kill-ring-do-insert bkr-buf sel-pos 'append))
(defun browse-kill-ring-insert-and-move (&optional quit append/prepend)
"Like `browse-kill-ring-insert', but move selection to front of ring.
Insert the selection at point unless optional arg
APPEND/PREPEND is:
`append' - insert at eob, not at point
`prepend' - insert at bob, not at point"
(interactive "P")
(let* ((bkr-buf (current-buffer))
(sel-pos (point))
(str (browse-kill-ring-current-string bkr-buf sel-pos)))
(browse-kill-ring-do-insert bkr-buf sel-pos append/prepend)
(browse-kill-ring-delete)
(if (eq 'kill-ring (browse-kill-ring-current-ring))
(kill-new str)
(funcall browse-kill-ring-alternative-push-function str)))
(if quit (browse-kill-ring-quit) (browse-kill-ring-update)))
(defun browse-kill-ring-prepend-insert-and-move (&optional quit)
"`browse-kill-ring-prepend-insert', but move selection to front of ring."
(interactive "P")
(browse-kill-ring-insert-and-move quit 'prepend))
(defun browse-kill-ring-append-insert-and-move (&optional quit)
"`browse-kill-ring-append-insert', but move selection to front of ring."
(interactive "P")
(browse-kill-ring-insert-and-move quit 'append))
(defun browse-kill-ring-forward (&optional arg)
"Move forward by ARG selection-ring entries."
(interactive "p")
(forward-line 0)
(while (not (zerop arg))
(if (< arg 0)
(progn (incf arg)
(if (overlays-at (point))
(progn
(goto-char (overlay-start (browse-kill-ring-target-overlay-at (point))))
(goto-char (previous-overlay-change (point)))
(goto-char (previous-overlay-change (point))))
(goto-char (previous-overlay-change (point)))
(goto-char (previous-overlay-change (point)))
(when (and (overlays-at (point)) (not (bobp)))
(goto-char (overlay-start (browse-kill-ring-target-overlay-at (point))))))
(forward-line 0))
(decf arg)
(if (overlays-at (point))
(progn (goto-char (overlay-end (browse-kill-ring-target-overlay-at (point))))
(goto-char (next-overlay-change (point)))
(while (not (bolp)) (goto-char (next-overlay-change (point)))))
(goto-char (next-overlay-change (point)))
(unless (eobp) (goto-char (overlay-start (browse-kill-ring-target-overlay-at (point))))))))
(when (and browse-kill-ring-highlight-current-entry (overlays-at (point)))
(let ((ovs (overlay-lists))
(current-ov (browse-kill-ring-target-overlay-at (point))))
(mapcar #'(lambda (ov) (overlay-put ov 'face nil)) (nconc (car ovs) (cdr ovs)))
(overlay-put current-ov 'face 'highlight)))
(when browse-kill-ring-recenter (recenter 1)))
(define-derived-mode browse-kill-ring-mode text-mode
"Selection-Ring"
"Major mode for browsing selection rings such as the `kill-ring'.
Do not call `browse-kill-ring-mode' directly - use `browse-kill-ring'.
\\{browse-kill-ring-mode-map}"
(set (make-local-variable 'font-lock-defaults)
'(nil t nil nil nil (font-lock-fontify-region-function . browse-kill-ring-fontify-region)))
(when (fboundp 'font-lock-refresh-defaults) (font-lock-refresh-defaults))
(use-local-map browse-kill-ring-mode-map)
(browse-kill-ring-current-ring))
(defun browse-kill-ring-default-keybindings ()
"Set up `M-y' so that it can invoke `browse-kill-ring'.
See also option `browse-kill-ring-yank-commands'."
(interactive)
(defadvice yank-pop (around kill-ring-browse-maybe (arg))
"If last action was not a yank, run `browse-kill-ring' instead."
(interactive "p")
(if (not (memq last-command browse-kill-ring-yank-commands))
(call-interactively #'browse-kill-ring)
(barf-if-buffer-read-only)
ad-do-it))
(ad-activate 'yank-pop))
(defun browse-kill-ring-edit ()
"Edit the current selection ring entry at point."
(interactive)
(forward-line 0)
(let ((ovs (overlays-at (point))))
(let* ((target (overlay-get (browse-kill-ring-target-overlay-at (point))
'browse-kill-ring-target))
(target-cell (member target (symbol-value (browse-kill-ring-current-ring)))))
(unless target-cell (error "Item deleted from the current selection ring"))
(switch-to-buffer (get-buffer-create "*Kill Ring Edit*"))
(setq buffer-read-only nil)
(erase-buffer)
(insert target)
(goto-char (point-min))
(browse-kill-ring-resize-window)
(browse-kill-ring-edit-mode)
(message (substitute-command-keys "Use `\\[browse-kill-ring-edit-finish]' to finish editing."))
(setq browse-kill-ring-edit-target target-cell))))
(defun browse-kill-ring-edit-finish ()
"Commit the changes to the current selection ring."
(interactive)
(if browse-kill-ring-edit-target
(setcar browse-kill-ring-edit-target (buffer-string))
(when (y-or-n-p "The item has been deleted; add to front? ")
(push (buffer-string) (symbol-value (browse-kill-ring-current-ring)))))
(bury-buffer)
(when (eq major-mode 'browse-kill-ring-mode)
(browse-kill-ring-setup (current-buffer) browse-kill-ring-original-window nil
browse-kill-ring-original-window-config)
(browse-kill-ring-resize-window)))
(defun browse-kill-ring-setup (bkr-buf window &optional regexp window-config)
"Set up buffer BKR-BUF as the selection-ring display buffer.
Turn on `browse-kill-ring-mode'.
Record `browse-kill-ring-original-window' and
`browse-kill-ring-original-window-config'.
Fill buffer with items from current selection ring, respecting REGEXP,
`browse-kill-ring-display-duplicates', and
`browse-kill-ring-display-style'."
(with-current-buffer bkr-buf
(unwind-protect
(progn
(browse-kill-ring-mode)
(setq buffer-read-only nil)
(when (eq browse-kill-ring-display-style 'one-line) (setq truncate-lines t))
(let ((inhibit-read-only t)) (erase-buffer))
(setq browse-kill-ring-original-window window
browse-kill-ring-original-window-config (or window-config
(current-window-configuration)))
(let ((items (mapcar (if browse-kill-ring-depropertize
#'browse-kill-ring-depropertize-string
#'copy-sequence)
(symbol-value (browse-kill-ring-current-ring))))
(browse-kill-ring-maximum-display-length
(if (and browse-kill-ring-maximum-display-length
(<= browse-kill-ring-maximum-display-length 3))
4
browse-kill-ring-maximum-display-length)))
(unless browse-kill-ring-display-duplicates
(setq items (browse-kill-ring-remove-dups items)))
(when (stringp regexp)
(setq items (delq nil (mapcar #'(lambda (item) (and (string-match regexp item) item))
items))))
(funcall (or (cdr (assq browse-kill-ring-display-style browse-kill-ring-display-styles))
(error "Invalid `browse-kill-ring-display-style': %s"
browse-kill-ring-display-style))
items)
(message (let* ((len (length (symbol-value browse-kill-ring-current-ring)))
(entry (if (= 1 len) "entry" "entries")))
(concat
(if (and (not regexp) browse-kill-ring-display-duplicates)
(format "%s %s in `%s'" len entry browse-kill-ring-current-ring)
(format "%s (of %s) %s in `%s' shown" (length items) len entry
browse-kill-ring-current-ring))
(substitute-command-keys " Use `\\[browse-kill-ring-quit]' to quit, \
`\\[describe-mode]' for help"))))
(set-buffer-modified-p nil)
(goto-char (point-min))
(browse-kill-ring-forward 0)
(when regexp (setq mode-name (concat "Selection-Ring [" regexp "]")))
(run-hooks 'browse-kill-ring-hook)
(when (and (featurep 'xemacs) font-lock-mode)
(browse-kill-ring-fontify-region (point-min) (point-max)))))
(setq buffer-read-only t))))
(defun browse-kill-ring (&optional other-ring-p)
"Browse the current selection ring.
With a prefix arg, browse the alternative selection ring instead.
\(If `browse-kill-ring-alternative-ring' is nil, then a prefix arg has
no effect.)"
(interactive "P")
(browse-kill-ring-current-ring)
(when (and other-ring-p browse-kill-ring-alternative-ring)
(setq browse-kill-ring-current-ring (if (eq browse-kill-ring-current-ring 'kill-ring)
browse-kill-ring-alternative-ring
'kill-ring)))
(let ((bkr-buf (get-buffer-create (format "*Selection Ring: `%s'*"
browse-kill-ring-current-ring))))
(unless (symbol-value browse-kill-ring-current-ring)
(message "`%s' is empty" browse-kill-ring-current-ring))
(browse-kill-ring-setup bkr-buf (if (eq major-mode 'browse-kill-ring-mode)
browse-kill-ring-original-window
(selected-window)))
(pop-to-buffer bkr-buf)
(select-frame-set-input-focus (window-frame (selected-window)))
(browse-kill-ring-resize-window))
nil)
(defun browse-kill-ring-switch-to-other-kill-ring ()
"Browse the other selection ring.
If the current ring is `kill-ring' then browse the alternative ring
\(e.g. `secondary-selection-ring'), and vice versa. The alternative
ring is the value of `browse-kill-ring-alternative-ring'."
(interactive)
(unless browse-kill-ring-alternative-ring (error "No alternative selection ring"))
(browse-kill-ring 'OTHER))
(defun browse-kill-ring-quit-deletes-window/frame ()
"Bury buffer. Delete window or, if dedicated, frame.
Useful as customized value of `browse-kill-ring-quit-action'."
(let ((buf (current-buffer))
(sole-window-p (eq (selected-window) (frame-root-window))))
(cond ((and sole-window-p (window-dedicated-p (selected-window)))
(delete-frame)
(bury-buffer buf))
(t
(unless sole-window-p (delete-window))
(with-current-buffer buf (bury-buffer))))))
(defun toggle-browse-kill-ring-display-style ()
"Toggle browse-kill-ring-display-style between `separated' and `one-line'."
(interactive)
(setq browse-kill-ring-display-style (case browse-kill-ring-display-style
(separated 'one-line)
(otherwise 'separated)))
(browse-kill-ring)
(browse-kill-ring-update)
(message "Display style is now %s" (upcase (symbol-name browse-kill-ring-display-style))))
(defun browse-kill-ring-copy-to-other-ring (&optional movep)
"Copy the selection at point from current selection ring to other ring.
With a prefix arg, move it instead of copying it.
If the other ring is also displayed, then its displayed is updated."
(interactive "P")
(forward-line 0)
(unwind-protect
(let* ((ov (browse-kill-ring-target-overlay-at (point)))
(seln (overlay-get ov 'browse-kill-ring-target)))
(setq buffer-read-only nil)
(when browse-kill-ring-depropertize
(setq seln (browse-kill-ring-depropertize-string seln)))
(if (eq 'kill-ring (browse-kill-ring-current-ring))
(funcall browse-kill-ring-alternative-push-function seln)
(kill-new seln))
(when movep
(delete-region (overlay-start ov) (1+ (overlay-end ov)))
(set browse-kill-ring-current-ring
(delete seln (symbol-value browse-kill-ring-current-ring)))
(when (get-text-property (point) 'browse-kill-ring-extra)
(let ((prev (previous-single-property-change (point) 'browse-kill-ring-extra))
(next (next-single-property-change (point) 'browse-kill-ring-extra)))
(when prev (incf prev))
(when next (incf next))
(delete-region (or prev (point-min)) (or next (point-max)))))))
(setq buffer-read-only t))
(browse-kill-ring-resize-window)
(browse-kill-ring-forward 0)
(let* ((other-ring (if (eq browse-kill-ring-current-ring 'kill-ring)
browse-kill-ring-alternative-ring
'kill-ring))
(other-buf (and other-ring (format "*Selection Ring: `%s'*" other-ring))))
(when (and other-buf (get-buffer-window other-buf 0))
(with-current-buffer other-buf (browse-kill-ring-update)))))
(browse-kill-ring-default-keybindings)
(provide 'browse-kill-ring+)