X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/233ba4d924933cb56129bd7511e6137b7c0b8e3e..d279e6680842b872ae3aab1fb429b1879db50f7f:/lisp/register.el

diff --git a/lisp/register.el b/lisp/register.el
index 517c50ee1e..b8fe613f92 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -1,8 +1,9 @@
-;;; register.el --- register commands for Emacs
+;;; register.el --- register commands for Emacs      -*- lexical-binding: t; -*-
 
-;; Copyright (C) 1985, 1993-1994, 2001-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1993-1994, 2001-2015 Free Software Foundation,
+;; Inc.
 
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
 ;; Keywords: internal
 ;; Package: emacs
 
@@ -28,31 +29,40 @@
 ;; pieces of buffer state to named variables.  The entry points are
 ;; documented in the Emacs user's manual.
 
-(declare-function semantic-insert-foreign-tag "semantic/tag" (foreign-tag))
-(declare-function semantic-tag-buffer "semantic/tag" (tag))
-(declare-function semantic-tag-start "semantic/tag" (tag))
-
-;;; Global key bindings
-
-(define-key ctl-x-r-map "\C-@" 'point-to-register)
-(define-key ctl-x-r-map [?\C-\ ] 'point-to-register)
-(define-key ctl-x-r-map " " 'point-to-register)
-(define-key ctl-x-r-map "j" 'jump-to-register)
-(define-key ctl-x-r-map "s" 'copy-to-register)
-(define-key ctl-x-r-map "x" 'copy-to-register)
-(define-key ctl-x-r-map "i" 'insert-register)
-(define-key ctl-x-r-map "g" 'insert-register)
-(define-key ctl-x-r-map "r" 'copy-rectangle-to-register)
-(define-key ctl-x-r-map "n" 'number-to-register)
-(define-key ctl-x-r-map "+" 'increment-register)
-(define-key ctl-x-r-map "w" 'window-configuration-to-register)
-(define-key ctl-x-r-map "f" 'frame-configuration-to-register)
+(eval-when-compile (require 'cl-lib))
 
 ;;; Code:
 
+(cl-defstruct
+  (registerv (:constructor nil)
+	     (:constructor registerv--make (&optional data print-func
+						      jump-func insert-func))
+	     (:copier nil)
+	     (:type vector)
+	     :named)
+  (data        nil :read-only t)
+  (print-func  nil :read-only t)
+  (jump-func   nil :read-only t)
+  (insert-func nil :read-only t))
+
+(cl-defun registerv-make (data &key print-func jump-func insert-func)
+  "Create a register value object.
+
+DATA can be any value.
+PRINT-FUNC if provided controls how `list-registers' and
+`view-register' print the register.  It should be a function
+receiving one argument DATA and print text that completes
+this sentence:
+  Register X contains [TEXT PRINTED BY PRINT-FUNC]
+JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register.
+INSERT-FUNC if provided, controls how `insert-register' insert the register.
+They both receive DATA as argument."
+  (registerv--make data print-func jump-func insert-func))
+
 (defvar register-alist nil
   "Alist of elements (NAME . CONTENTS), one for each Emacs register.
-NAME is a character (a number).  CONTENTS is a string, number, marker or list.
+NAME is a character (a number).  CONTENTS is a string, number, marker, list
+or a struct returned by `registerv-make'.
 A list of strings represents a rectangle.
 A list of the form (file . FILE-NAME) represents the file named FILE-NAME.
 A list of the form (file-query FILE-NAME POSITION) represents
@@ -63,6 +73,29 @@ A list of the form (WINDOW-CONFIGURATION POSITION)
 A list of the form (FRAME-CONFIGURATION POSITION)
  represents a saved frame configuration plus a saved value of point.")
 
+(defgroup register nil
+  "Register commands."
+  :group 'convenience
+  :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] (or \\[prepend-to-register]),
+contents of this register is added to the beginning (or end, respectively)
+of the marked text."
+  :group 'register
+  :type '(choice (const :tag "None" nil)
+		 (character :tag "Use register" :value ?+)))
+
+(defcustom register-preview-delay 1
+  "If non-nil, time to wait in seconds before popping up a preview window.
+If nil, do not show register previews, unless `help-char' (or a member of
+`help-event-list') is pressed."
+  :version "24.4"
+  :type '(choice number (const :tag "No preview unless requested" nil))
+  :group 'register)
+
 (defun get-register (register)
   "Return contents of Emacs register named REGISTER, or nil if none."
   (cdr (assq register register-alist)))
@@ -76,50 +109,142 @@ See the documentation of the variable `register-alist' for possible VALUEs."
       (push (cons register value) register-alist))
     value))
 
+(defun register-describe-oneline (c)
+  "One-line description of register C."
+  (let ((d (replace-regexp-in-string
+            "\n[ \t]*" " "
+            (with-output-to-string (describe-register-1 c)))))
+    (if (string-match "Register.+? contains \\(?:an? \\|the \\)?" d)
+        (substring d (match-end 0))
+      d)))
+
+(defun register-preview-default (r)
+  "Default function for the variable `register-preview-function'."
+  (format "%s: %s\n"
+	  (single-key-description (car r))
+	  (register-describe-oneline (car r))))
+
+(defvar register-preview-function #'register-preview-default
+  "Function to format a register for previewing.
+Takes one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
+Returns a string.")
+
+(defun register-preview (buffer &optional show-empty)
+  "Pop up a window to show register preview in BUFFER.
+If SHOW-EMPTY is non-nil show the window even if no registers.
+Format of each entry is controlled by the variable `register-preview-function'."
+  (when (or show-empty (consp register-alist))
+    (with-current-buffer-window
+     buffer
+     (cons 'display-buffer-below-selected
+	   '((window-height . fit-window-to-buffer)))
+     nil
+     (with-current-buffer standard-output
+       (setq cursor-in-non-selected-windows nil)
+       (insert (mapconcat register-preview-function register-alist ""))))))
+
+(defun register-read-with-preview (prompt)
+  "Read and return a register name, possibly showing existing registers.
+Prompt with the string PROMPT.  If `register-alist' and
+`register-preview-delay' are both non-nil, display a window
+listing existing registers after `register-preview-delay' seconds.
+If `help-char' (or a member of `help-event-list') is pressed,
+display such a window regardless."
+  (let* ((buffer "*Register Preview*")
+	 (timer (when (numberp register-preview-delay)
+		  (run-with-timer register-preview-delay nil
+				  (lambda ()
+				    (unless (get-buffer-window buffer)
+				      (register-preview buffer))))))
+	 (help-chars (cl-loop for c in (cons help-char help-event-list)
+			      when (not (get-register c))
+			      collect c)))
+    (unwind-protect
+	(progn
+	  (while (memq (read-event (propertize prompt 'face 'minibuffer-prompt))
+		       help-chars)
+	    (unless (get-buffer-window buffer)
+	      (register-preview buffer 'show-empty)))
+	  (if (characterp last-input-event) last-input-event
+	    (error "Non-character input-event")))
+      (and (timerp timer) (cancel-timer timer))
+      (let ((w (get-buffer-window buffer)))
+        (and (window-live-p w) (delete-window w)))
+      (and (get-buffer buffer) (kill-buffer buffer)))))
+
 (defun point-to-register (register &optional arg)
   "Store current location of point in register REGISTER.
 With prefix argument, store current frame configuration.
 Use \\[jump-to-register] to go to that location or restore that configuration.
-Argument is a character, naming the register."
-  (interactive "cPoint to register: \nP")
+Argument is a character, naming the register.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview "Point to register: ")
+		     current-prefix-arg))
   ;; Turn the marker into a file-ref if the buffer is killed.
   (add-hook 'kill-buffer-hook 'register-swap-out nil t)
   (set-register register
 		(if arg (list (current-frame-configuration) (point-marker))
 		  (point-marker))))
 
-(defun window-configuration-to-register (register &optional arg)
+(defun window-configuration-to-register (register &optional _arg)
   "Store the window configuration of the selected frame in register REGISTER.
 Use \\[jump-to-register] to restore the configuration.
-Argument is a character, naming the register."
-  (interactive "cWindow configuration to register: \nP")
+Argument is a character, naming the register.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview
+		      "Window configuration to register: ")
+		     current-prefix-arg))
   ;; current-window-configuration does not include the value
   ;; of point in the current buffer, so record that separately.
   (set-register register (list (current-window-configuration) (point-marker))))
 
-(defun frame-configuration-to-register (register &optional arg)
+;; It has had the optional arg for ages, but never used it.
+(set-advertised-calling-convention 'window-configuration-to-register
+				   '(register) "24.4")
+
+(defun frame-configuration-to-register (register &optional _arg)
   "Store the window configuration of all frames in register REGISTER.
 Use \\[jump-to-register] to restore the configuration.
-Argument is a character, naming the register."
-  (interactive "cFrame configuration to register: \nP")
+Argument is a character, naming the register.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview
+		      "Frame configuration to register: ")
+		     current-prefix-arg))
   ;; current-frame-configuration does not include the value
   ;; of point in the current buffer, so record that separately.
   (set-register register (list (current-frame-configuration) (point-marker))))
 
+;; It has had the optional arg for ages, but never used it.
+(set-advertised-calling-convention 'frame-configuration-to-register
+				   '(register) "24.4")
+
+(make-obsolete 'frame-configuration-to-register 'frameset-to-register' "24.4")
+
 (defalias 'register-to-point 'jump-to-register)
 (defun jump-to-register (register &optional delete)
   "Move point to location stored in a register.
 If the register contains a file name, find that file.
 \(To put a file name in a register, you must use `set-register'.)
-If the register contains a window configuration (one frame) or a frame
-configuration (all frames), restore that frame or all frames accordingly.
+If the register contains a window configuration (one frame) or a frameset
+\(all frames), restore that frame or all frames accordingly.
 First argument is a character, naming the register.
 Optional second arg non-nil (interactively, prefix argument) says to
-delete any existing frames that the frame configuration doesn't mention.
-\(Otherwise, these frames are iconified.)"
-  (interactive "cJump to register: \nP")
+delete any existing frames that the frameset doesn't mention.
+\(Otherwise, these frames are iconified.)
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview "Jump to register: ")
+		     current-prefix-arg))
   (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))
       (goto-char (cadr val)))
@@ -139,11 +264,6 @@ delete any existing frames that the frame configuration doesn't mention.
 	  (error "Register access aborted"))
       (find-file (nth 1 val))
       (goto-char (nth 2 val)))
-     ((and (fboundp 'semantic-foreign-tag-p)
-	   semantic-mode
-	   (semantic-foreign-tag-p val))
-      (switch-to-buffer (semantic-tag-buffer val))
-      (goto-char (semantic-tag-start val)))
      (t
       (error "Register doesn't contain a buffer position or configuration")))))
 
@@ -163,8 +283,11 @@ delete any existing frames that the frame configuration doesn't mention.
 Two args, NUMBER and REGISTER (a character, naming the register).
 If NUMBER is nil, a decimal number is read from the buffer starting
 at point, and point moves to the end of that number.
-Interactively, NUMBER is the prefix arg (none means nil)."
-  (interactive "P\ncNumber to register: ")
+Interactively, NUMBER is the prefix arg (none means nil).
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list current-prefix-arg
+		     (register-read-with-preview "Number to register: ")))
   (set-register register
 		(if number
 		    (prefix-numeric-value number)
@@ -174,18 +297,34 @@ Interactively, NUMBER is the prefix arg (none means nil)."
 			(string-to-number (match-string 0)))
 		    0))))
 
-(defun increment-register (number register)
-  "Add NUMBER to the contents of register REGISTER.
-Interactively, NUMBER is the prefix arg."
-  (interactive "p\ncIncrement register: ")
-  (or (numberp (get-register register))
-      (error "Register does not contain a number"))
-  (set-register register (+ number (get-register register))))
+(defun increment-register (prefix register)
+  "Augment contents of REGISTER.
+Interactively, PREFIX is in raw form.
+
+If REGISTER contains a number, add `prefix-numeric-value' of
+PREFIX to it.
+
+If REGISTER is empty or if it contains text, call
+`append-to-register' with `delete-flag' set to PREFIX.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list current-prefix-arg
+		     (register-read-with-preview "Increment register: ")))
+  (let ((register-val (get-register register)))
+    (cond
+     ((numberp register-val)
+      (let ((number (prefix-numeric-value prefix)))
+	(set-register register (+ number register-val))))
+     ((or (not register-val) (stringp register-val))
+      (append-to-register register (region-beginning) (region-end) prefix))
+     (t (error "Register does not contain a number or text")))))
 
 (defun view-register (register)
   "Display what is contained in register named REGISTER.
-The Lisp value REGISTER is a character."
-  (interactive "cView register: ")
+The Lisp value REGISTER is a character.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview "View register: ")))
   (let ((val (get-register register)))
     (if (null val)
 	(message "Register %s is empty" (single-key-description register))
@@ -209,6 +348,11 @@ The Lisp value REGISTER is a character."
   (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))
 
@@ -252,6 +396,7 @@ The Lisp value REGISTER is a character."
 	(princ (car val))))
 
      ((stringp val)
+      (setq val (copy-sequence val))
       (if (eq yank-excluded-properties t)
 	  (set-text-properties 0 (length val) nil val)
 	(remove-list-of-text-properties 0 (length val)
@@ -280,11 +425,21 @@ The Lisp value REGISTER is a character."
   "Insert contents of register REGISTER.  (REGISTER is a character.)
 Normally puts point before and mark after the inserted text.
 If optional second arg is non-nil, puts mark before and point after.
-Interactively, second arg is non-nil if prefix arg is supplied."
-  (interactive "*cInsert register: \nP")
+Interactively, second arg is non-nil if prefix arg is supplied.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (progn
+		 (barf-if-buffer-read-only)
+		 (list (register-read-with-preview "Insert register: ")
+		       current-prefix-arg)))
   (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))
      ((stringp val)
@@ -293,50 +448,80 @@ Interactively, second arg is non-nil if prefix arg is supplied."
       (princ val (current-buffer)))
      ((and (markerp val) (marker-position val))
       (princ (marker-position val) (current-buffer)))
-     ((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)
+(defun copy-to-register (register start end &optional delete-flag region)
   "Copy region into register REGISTER.
 With prefix arg, delete as well.
-Called from program, takes four args: REGISTER, START, END and DELETE-FLAG.
-START and END are buffer positions indicating what to copy."
-  (interactive "cCopy to register: \nr\nP")
-  (set-register register (filter-buffer-substring start end))
-  (if delete-flag (delete-region start end)))
+Called from program, takes five args: REGISTER, START, END, DELETE-FLAG,
+and REGION.  START and END are buffer positions indicating what to copy.
+The optional argument REGION if non-nil, indicates that we're not just
+copying some text between START and END, but we're copying the region.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview "Copy to register: ")
+		     (region-beginning)
+		     (region-end)
+		     current-prefix-arg
+		     t))
+  (set-register register (if region
+			     (funcall region-extract-function delete-flag)
+			   (prog1 (filter-buffer-substring start end)
+			     (if delete-flag (delete-region start end)))))
+  (setq deactivate-mark t)
+  (cond (delete-flag)
+	((called-interactively-p 'interactive)
+	 (indicate-copied-region))))
 
 (defun append-to-register (register start end &optional delete-flag)
   "Append region to text in register REGISTER.
 With prefix arg, delete as well.
 Called from program, takes four args: REGISTER, START, END and DELETE-FLAG.
-START and END are buffer positions indicating what to append."
-  (interactive "cAppend to register: \nr\nP")
+START and END are buffer positions indicating what to append.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview "Append to register: ")
+		     (region-beginning)
+		     (region-end)
+		     current-prefix-arg))
   (let ((reg (get-register register))
-        (text (filter-buffer-substring start end)))
+        (text (filter-buffer-substring start end))
+	(separator (and register-separator (get-register register-separator))))
     (set-register
      register (cond ((not reg) text)
-                    ((stringp reg) (concat reg text))
+                    ((stringp reg) (concat reg separator text))
                     (t (error "Register does not contain text")))))
-  (if delete-flag (delete-region start end)))
+  (setq deactivate-mark t)
+  (cond (delete-flag
+	 (delete-region start end))
+	((called-interactively-p 'interactive)
+	 (indicate-copied-region))))
 
 (defun prepend-to-register (register start end &optional delete-flag)
   "Prepend region to text in register REGISTER.
 With prefix arg, delete as well.
 Called from program, takes four args: REGISTER, START, END and DELETE-FLAG.
-START and END are buffer positions indicating what to prepend."
-  (interactive "cPrepend to register: \nr\nP")
+START and END are buffer positions indicating what to prepend.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview "Prepend to register: ")
+		     (region-beginning)
+		     (region-end)
+		     current-prefix-arg))
   (let ((reg (get-register register))
-        (text (filter-buffer-substring start end)))
+        (text (filter-buffer-substring start end))
+	(separator (and register-separator (get-register register-separator))))
     (set-register
      register (cond ((not reg) text)
-                    ((stringp reg) (concat text reg))
+                    ((stringp reg) (concat text separator reg))
                     (t (error "Register does not contain text")))))
-  (if delete-flag (delete-region start end)))
+  (setq deactivate-mark t)
+  (cond (delete-flag
+	 (delete-region start end))
+	((called-interactively-p 'interactive)
+	 (indicate-copied-region))))
 
 (defun copy-rectangle-to-register (register start end &optional delete-flag)
   "Copy rectangular region into register REGISTER.
@@ -344,12 +529,22 @@ With prefix arg, delete as well.
 To insert this register in the buffer, use \\[insert-register].
 
 Called from a program, takes four args: REGISTER, START, END and DELETE-FLAG.
-START and END are buffer positions giving two corners of rectangle."
-  (interactive "cCopy rectangle to register: \nr\nP")
-  (set-register register
-		(if delete-flag
-		    (delete-extract-rectangle start end)
-		  (extract-rectangle start end))))
+START and END are buffer positions giving two corners of rectangle.
+
+Interactively, reads the register using `register-read-with-preview'."
+  (interactive (list (register-read-with-preview
+		      "Copy rectangle to register: ")
+		     (region-beginning)
+		     (region-end)
+		     current-prefix-arg))
+  (let ((rectangle (if delete-flag
+		       (delete-extract-rectangle start end)
+		     (extract-rectangle start end))))
+    (set-register register rectangle)
+    (when (and (null delete-flag)
+	       (called-interactively-p 'interactive))
+      (setq deactivate-mark t)
+      (indicate-copied-region (length (car rectangle))))))
 
 (provide 'register)
 ;;; register.el ends here