unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
* [patch]  minor patch for register.el
@ 2013-02-19 23:18 Drew Adams
  2013-02-20  2:18 ` Masatake YAMATO
                   ` (2 more replies)
  0 siblings, 3 replies; 15+ messages in thread
From: Drew Adams @ 2013-02-19 23:18 UTC (permalink / raw)
  To: emacs-devel

[-- 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

^ permalink raw reply	[flat|nested] 15+ messages in thread
end of thread, other threads:[~2013-03-11 20:46 UTC | newest]

Thread overview: 15+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2013-02-19 23:18 [patch] minor patch for register.el Drew Adams
2013-02-20  2:18 ` 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

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).