mcgrath@HOMER.BERKELEY.EDU (Roland McGrath) (08/08/90)
I have rewritten the copying-kill command I posted yesterday (twice).
If you missed it, copying-kill lets you perform any killing command without
deleting text, just saving it in the kill-ring, like copy-region-as-kill.
This version is more robust (using unwind-protect like any good lisp hack
should), and has two significant enhancements:
1. It works on any number of consecutive killing commands, preserving the
normal behavior of consecutive kills appending so they can be yanked all
at once.
2. It works with prefix arguments. If you give a prefix argument before
doing copying-kill, it will apply to the first command done thereafter.
You can also give prefix arguments after doing copying-kill, and they
won't pop you out of copying-kill.
So, for example, with copying-kill on C-c C-y (where I put it),
C-a M-f C-c C-y M-DEL C-u M-d on the first line of this sentence, followed by a
C-y somewhere, yanks "SoSo, for example, with".
Enjoy,
Roland
;;; copy-kill.el -- Perform killing commands without killing.
;;;
;;; Copyright (C) 1990 Roland McGrath
;;;
;;; 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 1, 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.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to roland@ai.mit.edu) or from
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;;
;;; Send bug reports to roland@ai.mit.edu.
;; To use this, byte-compile this file, and then put the following line
;; in your .emacs (or site-init.el, etc.):
;; (autoload 'copying-kill "copy-kill" nil t)
;;
;; To bind this to a key, do, for example:
;; (global-set-key "\C-c\C-y" 'copying-kill)
(defun copying-kill ()
"Execute following killing commands so they don't kill, but still save.
Consecutive killing commands done after typing \\[copying-kill] all copy to the
kill-ring without deleting any text. Killing commands go back to deleting text
as normal as soon a command that is not a killing command or
\\[universal-argument] is done.
If echo-keystrokes (which see) is nonzero, \\[copying-kill] is echoed before
each key sequence is read to tell you copying-kill is still active."
(interactive)
(let ((saved-defs
;; Replace functions which we want to cause us to continue the main
;; loop, with versions that leave a marker for us.
;; Elts in the list to be mapcar'd are (FUNC . CALL).
;; FUNC is the function to be replaced.
;; CALL is the function to call instead, before leaving the marker.
;; If CALL is nil, FUNC's original definition is used.
(mapcar
(function
(lambda (elt)
(let* ((func (car elt))
(def (symbol-function func))
(call (or (cdr elt) def))
(args (car (cdr def))))
(prog1 (cons func def)
(fset func (list 'lambda args
"\
You are in the middle of \\[copying-kill].
Ask for help on this function again to get the real version."
;; Use the original interactive spec.
(assq 'interactive (symbol-function func))
(list 'prog1
;;
(apply 'list call args)
;; Tell copy-region-as-kill that
;; consecutive kills are happening.
'(setq last-command 'kill-region)
;; Leave a marker that will be picked
;; up in the main loop.
'(setq this-command
'copying-kill-marker))))))))
'((kill-region . copy-region-as-kill)
(universal-argument)
(digit-argument)
(negative-argument))))
(read-keys-form (if (zerop echo-keystrokes)
;; No keystroke echoing.
'(read-key-sequence nil)
;; We want keystroke echoing, so construct a form
;; that does prompting and echoing.
(let ((prompt (this-command-keys)))
(if current-prefix-arg
(let* ((i (length prompt))
(key (substring prompt i)))
(while (and (> i 0)
(not (eq (key-binding key)
this-command)))
(setq i (1- i)
key (substring prompt i)))
(setq prompt
(if (zerop i)
(where-is-internal
this-command
(current-local-map) t)
key)))
(if (not (eq (key-binding prompt) this-command))
(setq prompt (where-is-internal
this-command
(current-local-map) t))))
(setq prompt (if prompt
(meta-key-description prompt)
(format "M-x %s" this-command)))
;; Construct a form that will read the keys with
;; prompting, and then echo them afterwards.
(`
(let ((prompt (concat (if prefix-arg
(concat (prin1-to-string
prefix-arg)
" "))
(, prompt)))
keys)
(setq keys (read-key-sequence
(concat prompt "-")))
(message "%s %s"
prompt
(key-description keys))
keys)))))
command result)
(unwind-protect
(progn
;; Give the prefix-arg to the first command we run.
(setq prefix-arg current-prefix-arg)
(while (if (null (setq command (key-binding (eval read-keys-form))))
;; There is no binding for the key the user hit.
(ding)
;; Execute the command we read, saving its result.
(setq result (let (saved-defs) (command-execute command)))
;; Continue the loop iff one of our override functions just
;; ran, leaving us a marker.
(eq this-command 'copying-kill-marker))
;; Reset this-command to remove the marker for the next iteration.
(setq this-command command))
;; Return the result of the last command done.
result)
;; Protect-form to restore the real definitions.
(while saved-defs
(fset (car (car saved-defs)) (cdr (car saved-defs)))
(setq saved-defs (cdr saved-defs))))))