From: "Drew Adams" <drew.adams@oracle.com>
To: <emacs-devel@gnu.org>
Subject: [patch] minor patch for register.el
Date: Tue, 19 Feb 2013 15:18:08 -0800 [thread overview]
Message-ID: <CFAB57590EFF4945AFF963FB23BB2CA8@us.oracle.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 724 bytes --]
If the attached patch is OK I will send a change log entry.
The patch does this:
1. Adds functions `register-insertable-p', `register-jumpable-p', and
`register-printable-p'.
2. In `jump-to-register':
. Use `register-jumpable-p'.
. Raise error if no such register or cannot jump to it.
3. In `view-register': Raise error if no such register.
4. In `list-registers': Raise error if `register-alist' is empty.
5. In `describe-register-1':
. Use `register-printable-p'.
. Wrap names with `...'.
6. In `insert-register':
. Use `register-insertable-p'.
. Raise error if no such register or cannot insert contents.
7. In `append-to-register' and `prepend-to-register':
Name the register in error msg.
[-- Attachment #2: register-2013-02-19.patch --]
[-- Type: application/octet-stream, Size: 13777 bytes --]
diff -c -w register.el register-patched-2013-02-19.el
*** register.el Tue Feb 19 10:40:22 2013
--- register-patched-2013-02-19.el Tue Feb 19 15:04:08 2013
***************
*** 83,90 ****
:version "24.3")
(defcustom register-separator nil
! "Register containing the text to put between collected texts, or nil if none.
!
When collecting text with
`append-to-register' (resp. `prepend-to-register') contents of
this register is added to the beginning (resp. end) of the marked
--- 83,89 ----
:version "24.3")
(defcustom register-separator nil
! "Register containing text to put between collected texts, or nil if none.
When collecting text with
`append-to-register' (resp. `prepend-to-register') contents of
this register is added to the beginning (resp. end) of the marked
***************
*** 106,111 ****
--- 105,157 ----
(push (cons register value) register-alist))
value))
+ (defun register-insertable-p (register)
+ "Return non-nil if the value of REGISTER can be inserted.
+ That is, whether it can be passed to `insert-register' without raising
+ an error."
+ (let ((val (get-register register)))
+ (or (and (registerv-p val) (registerv-insert-func val))
+ (consp val)
+ (stringp val)
+ (numberp val)
+ (and (markerp val) (marker-position val))
+ (and (fboundp 'semantic-foreign-tag-p)
+ semantic-mode
+ (semantic-foreign-tag-p val)))))
+
+ (defun register-jumpable-p (register &optional msgp)
+ "Return non-nil if the value of REGISTER can be jumped to.
+ That is, whether it can be passed to `jump-to-register' without
+ raising an error.
+
+ Non-nil optional arg MSGP means the function can query the user
+ whether to revisit a file whose buffer no longer exists."
+ (let ((val (get-register register)))
+ (or (and (registerv-p val) (registerv-jump-func val))
+ (and (consp val)
+ (or (frame-configuration-p (car val))
+ (window-configuration-p (car val))
+ (eq (car val) 'file)
+ (and (eq (car val) 'file-query)
+ (or (find-buffer-visiting (nth 1 val))
+ (and msgp
+ (y-or-n-p (format "Visit file `%s' again? "
+ (nth 1 val))))))))
+ (and (markerp val) (marker-buffer val))
+ (and (fboundp 'semantic-foreign-tag-p)
+ semantic-mode
+ (semantic-foreign-tag-p val)))))
+
+ (defun register-printable-p (register)
+ "Return non-nil if the value of REGISTER can be printed.
+ That is, whether the value is a recognized register value."
+ (let ((val (get-register register)))
+ (or (and (registerv-p val) (registerv-print-func val))
+ (consp val) ; Includes rectangle.
+ (numberp val)
+ (markerp val)
+ (stringp val))))
+
(defun point-to-register (register &optional arg)
"Store current location of point in register REGISTER.
With prefix argument, store current frame configuration.
***************
*** 148,159 ****
delete any existing frames that the frame configuration doesn't mention.
\(Otherwise, these frames are iconified.)"
(interactive "cJump to register: \nP")
(let ((val (get-register register)))
! (cond
! ((registerv-p val)
! (cl-assert (registerv-jump-func val) nil
! "Don't know how to jump to register %s"
! (single-key-description register))
(funcall (registerv-jump-func val) (registerv-data val)))
((and (consp val) (frame-configuration-p (car val)))
(set-frame-configuration (car val) (not delete))
--- 194,205 ----
delete any existing frames that the frame configuration doesn't mention.
\(Otherwise, these frames are iconified.)"
(interactive "cJump to register: \nP")
+ (unless (get-register register)
+ (error "No such register: `%s'" (single-key-description register)))
+ (unless (register-jumpable-p register (called-interactively-p 'interactive))
+ (error "Cannot jump to register `%s'" (single-key-description register)))
(let ((val (get-register register)))
! (cond ((registerv-p val)
(funcall (registerv-jump-func val) (registerv-data val)))
((and (consp val) (frame-configuration-p (car val)))
(set-frame-configuration (car val) (not delete))
***************
*** 234,264 ****
(interactive "cView register: ")
(let ((val (get-register register)))
(if (null val)
! (message "Register %s is empty" (single-key-description register))
(with-output-to-temp-buffer "*Output*"
(describe-register-1 register t)))))
(defun list-registers ()
"Display a list of nonempty registers saying briefly what they contain."
(interactive)
(let ((list (copy-sequence register-alist)))
(setq list (sort list (lambda (a b) (< (car a) (car b)))))
(with-output-to-temp-buffer "*Output*"
(dolist (elt list)
(when (get-register (car elt))
(describe-register-1 (car elt))
! (terpri))))))
(defun describe-register-1 (register &optional verbose)
- (princ "Register ")
- (princ (single-key-description register))
- (princ " contains ")
(let ((val (get-register register)))
! (cond
((registerv-p val)
! (if (registerv-print-func val)
! (funcall (registerv-print-func val) (registerv-data val))
! (princ "[UNPRINTABLE CONTENTS].")))
((numberp val)
(princ val))
--- 280,314 ----
(interactive "cView register: ")
(let ((val (get-register register)))
(if (null val)
! (error "No such register: `%s'" (single-key-description register))
(with-output-to-temp-buffer "*Output*"
(describe-register-1 register t)))))
(defun list-registers ()
"Display a list of nonempty registers saying briefly what they contain."
(interactive)
+ (if (null register-alist)
+ (error "No registers to describe")
(let ((list (copy-sequence register-alist)))
(setq list (sort list (lambda (a b) (< (car a) (car b)))))
(with-output-to-temp-buffer "*Output*"
(dolist (elt list)
(when (get-register (car elt))
(describe-register-1 (car elt))
! (terpri)))))))
(defun describe-register-1 (register &optional verbose)
(let ((val (get-register register)))
! (princ "Register `")
! (princ (single-key-description register))
! (princ "' contains ")
! (cond ((not (register-printable-p register))
! (if verbose
! (format "garbage (?):\n%S" val))
! "unprintable contents.")
!
((registerv-p val)
! (funcall (registerv-print-func val) (registerv-data val)))
((numberp val)
(princ val))
***************
*** 266,275 ****
((markerp val)
(let ((buf (marker-buffer val)))
(if (null buf)
! (princ "a marker in no buffer")
! (princ "a buffer position:\n buffer ")
(princ (buffer-name buf))
! (princ ", position ")
(princ (marker-position val)))))
((and (consp val) (window-configuration-p (car val)))
--- 316,325 ----
((markerp val)
(let ((buf (marker-buffer val)))
(if (null buf)
! (princ "a marker in no buffer.")
! (princ "a buffer position:\n buffer `")
(princ (buffer-name buf))
! (princ "', position ")
(princ (marker-position val)))))
((and (consp val) (window-configuration-p (car val)))
***************
*** 279,292 ****
(princ "a frame configuration."))
((and (consp val) (eq (car val) 'file))
! (princ "the file ")
(prin1 (cdr val))
! (princ "."))
((and (consp val) (eq (car val) 'file-query))
! (princ "a file-query reference:\n file ")
(prin1 (car (cdr val)))
! (princ ",\n position ")
(princ (car (cdr (cdr val))))
(princ "."))
--- 329,342 ----
(princ "a frame configuration."))
((and (consp val) (eq (car val) 'file))
! (princ "the file `")
(prin1 (cdr val))
! (princ "'."))
((and (consp val) (eq (car val) 'file-query))
! (princ "a file-query reference:\n file `")
(prin1 (car (cdr val)))
! (princ "',\n position ")
(princ (car (cdr (cdr val))))
(princ "."))
***************
*** 312,320 ****
(princ "the text:\n")
(princ val))
(cond
! ;; Extract first N characters starting with first non-whitespace.
((string-match (format "[^ \t\n].\\{,%d\\}"
! ;; Deduct 6 for the spaces inserted below.
(min 20 (max 0 (- (window-width) 6))))
val)
(princ "text starting with\n ")
--- 362,370 ----
(princ "the text:\n")
(princ val))
(cond
! ;; Extract first N chars, starting with first non-whitespace.
((string-match (format "[^ \t\n].\\{,%d\\}"
! ;; Deduct 6 for spaces inserted below.
(min 20 (max 0 (- (window-width) 6))))
val)
(princ "text starting with\n ")
***************
*** 322,331 ****
((string-match "^[ \t\n]+$" val)
(princ "whitespace"))
(t
! (princ "the empty string")))))
! (t
! (princ "Garbage:\n")
! (if verbose (prin1 val))))))
(defun insert-register (register &optional arg)
"Insert contents of register REGISTER. (REGISTER is a character.)
--- 372,378 ----
((string-match "^[ \t\n]+$" val)
(princ "whitespace"))
(t
! (princ "the empty string"))))))))
(defun insert-register (register &optional arg)
"Insert contents of register REGISTER. (REGISTER is a character.)
***************
*** 334,345 ****
Interactively, second arg is non-nil if prefix arg is supplied."
(interactive "*cInsert register: \nP")
(push-mark)
(let ((val (get-register register)))
! (cond
! ((registerv-p val)
! (cl-assert (registerv-insert-func val) nil
! "Don't know how to insert register %s"
! (single-key-description register))
(funcall (registerv-insert-func val) (registerv-data val)))
((consp val)
(insert-rectangle val))
--- 381,393 ----
Interactively, second arg is non-nil if prefix arg is supplied."
(interactive "*cInsert register: \nP")
(push-mark)
+ (unless (get-register register)
+ (error "No such register: `%s'" (single-key-description register)))
+ (unless (register-insertable-p register)
+ (error "Cannot insert the contents of register `%s'"
+ (single-key-description register)))
(let ((val (get-register register)))
! (cond ((registerv-p val)
(funcall (registerv-insert-func val) (registerv-data val)))
((consp val)
(insert-rectangle val))
***************
*** 352,361 ****
((and (fboundp 'semantic-foreign-tag-p)
semantic-mode
(semantic-foreign-tag-p val))
! (semantic-insert-foreign-tag val))
! (t
! (error "Register does not contain text"))))
! (if (not arg) (exchange-point-and-mark)))
(defun copy-to-register (register start end &optional delete-flag)
"Copy region into register REGISTER.
--- 400,407 ----
((and (fboundp 'semantic-foreign-tag-p)
semantic-mode
(semantic-foreign-tag-p val))
! (semantic-insert-foreign-tag val))))
! (unless arg (exchange-point-and-mark)))
(defun copy-to-register (register start end &optional delete-flag)
"Copy region into register REGISTER.
***************
*** 382,388 ****
(set-register
register (cond ((not reg) text)
((stringp reg) (concat reg separator text))
! (t (error "Register does not contain text")))))
(setq deactivate-mark t)
(cond (delete-flag
(delete-region start end))
--- 428,435 ----
(set-register
register (cond ((not reg) text)
((stringp reg) (concat reg separator text))
! (t (error "Register `%s' does not contain text"
! (single-key-description register))))))
(setq deactivate-mark t)
(cond (delete-flag
(delete-region start end))
***************
*** 401,407 ****
(set-register
register (cond ((not reg) text)
((stringp reg) (concat text separator reg))
! (t (error "Register does not contain text")))))
(setq deactivate-mark t)
(cond (delete-flag
(delete-region start end))
--- 448,455 ----
(set-register
register (cond ((not reg) text)
((stringp reg) (concat text separator reg))
! (t (error "Register `%s' does not contain text"
! (single-key-description register))))))
(setq deactivate-mark t)
(cond (delete-flag
(delete-region start end))
Diff finished. Tue Feb 19 15:05:49 2013
next reply other threads:[~2013-02-19 23:18 UTC|newest]
Thread overview: 15+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-02-19 23:18 Drew Adams [this message]
2013-02-20 2:18 ` [patch] minor patch for register.el Masatake YAMATO
2013-02-20 4:30 ` Drew Adams
2013-02-20 14:48 ` John Yates
2013-02-20 14:53 ` Christopher Schmidt
2013-02-20 15:27 ` Drew Adams
2013-02-20 17:05 ` Stefan Monnier
2013-02-20 23:15 ` Drew Adams
2013-03-11 18:01 ` Stefan Monnier
2013-03-11 20:46 ` Drew Adams
2013-02-21 20:29 ` Bastien
2013-02-21 21:20 ` Drew Adams
2013-02-21 21:25 ` Bastien
2013-02-21 21:29 ` Drew Adams
2013-02-21 21:34 ` Drew Adams
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=CFAB57590EFF4945AFF963FB23BB2CA8@us.oracle.com \
--to=drew.adams@oracle.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).