LCOV - code coverage report
Current view: top level - lisp - register.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 0 273 0.0 %
Date: 2017-08-30 10:12:24 Functions: 0 25 0.0 %

          Line data    Source code
       1             : ;;; register.el --- register commands for Emacs      -*- lexical-binding: t; -*-
       2             : 
       3             : ;; Copyright (C) 1985, 1993-1994, 2001-2017 Free Software Foundation,
       4             : ;; Inc.
       5             : 
       6             : ;; Maintainer: emacs-devel@gnu.org
       7             : ;; Keywords: internal
       8             : ;; Package: emacs
       9             : 
      10             : ;; This file is part of GNU Emacs.
      11             : 
      12             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      13             : ;; it under the terms of the GNU General Public License as published by
      14             : ;; the Free Software Foundation, either version 3 of the License, or
      15             : ;; (at your option) any later version.
      16             : 
      17             : ;; GNU Emacs is distributed in the hope that it will be useful,
      18             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      19             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      20             : ;; GNU General Public License for more details.
      21             : 
      22             : ;; You should have received a copy of the GNU General Public License
      23             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      24             : 
      25             : ;;; Commentary:
      26             : 
      27             : ;; This package of functions emulates and somewhat extends the venerable
      28             : ;; TECO's `register' feature, which permits you to save various useful
      29             : ;; pieces of buffer state to named variables.  The entry points are
      30             : ;; documented in the Emacs user's manual: (info "(emacs) Registers").
      31             : 
      32             : (eval-when-compile (require 'cl-lib))
      33             : 
      34             : ;;; Code:
      35             : 
      36             : ;; FIXME: Clean up namespace usage!
      37             : 
      38             : (cl-defstruct
      39             :   (registerv (:constructor nil)
      40             :              (:constructor registerv--make (&optional data print-func
      41             :                                                       jump-func insert-func))
      42             :              (:copier nil)
      43             :              (:type vector)
      44             :              :named)
      45             :   (data        nil :read-only t)
      46             :   (print-func  nil :read-only t)
      47             :   (jump-func   nil :read-only t)
      48             :   (insert-func nil :read-only t))
      49             : 
      50             : (cl-defun registerv-make (data &key print-func jump-func insert-func)
      51             :   "Create a register value object.
      52             : 
      53             : DATA can be any value.
      54             : PRINT-FUNC if provided controls how `list-registers' and
      55             : `view-register' print the register.  It should be a function
      56             : receiving one argument DATA and print text that completes
      57             : this sentence:
      58             :   Register X contains [TEXT PRINTED BY PRINT-FUNC]
      59             : JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register.
      60             : INSERT-FUNC if provided, controls how `insert-register' insert the register.
      61             : They both receive DATA as argument."
      62           0 :   (registerv--make data print-func jump-func insert-func))
      63             : 
      64             : (defvar register-alist nil
      65             :   "Alist of elements (NAME . CONTENTS), one for each Emacs register.
      66             : NAME is a character (a number).  CONTENTS is a string, number, marker, list
      67             : or a struct returned by `registerv-make'.
      68             : A list of strings represents a rectangle.
      69             : A list of the form (file . FILE-NAME) represents the file named FILE-NAME.
      70             : A list of the form (file-query FILE-NAME POSITION) represents
      71             :  position POSITION in the file named FILE-NAME, but query before
      72             :  visiting it.
      73             : A list of the form (WINDOW-CONFIGURATION POSITION)
      74             :  represents a saved window configuration plus a saved value of point.
      75             : A list of the form (FRAME-CONFIGURATION POSITION)
      76             :  represents a saved frame configuration plus a saved value of point.")
      77             : 
      78             : (defgroup register nil
      79             :   "Register commands."
      80             :   :group 'convenience
      81             :   :version "24.3")
      82             : 
      83             : (defcustom register-separator nil
      84             :   "Register containing the text to put between collected texts, or nil if none.
      85             : 
      86             : When collecting text with \\[append-to-register] (or \\[prepend-to-register]),
      87             : contents of this register is added to the beginning (or end, respectively)
      88             : of the marked text."
      89             :   :group 'register
      90             :   :type '(choice (const :tag "None" nil)
      91             :                  (character :tag "Use register" :value ?+)))
      92             : 
      93             : (defcustom register-preview-delay 1
      94             :   "If non-nil, time to wait in seconds before popping up a preview window.
      95             : If nil, do not show register previews, unless `help-char' (or a member of
      96             : `help-event-list') is pressed."
      97             :   :version "24.4"
      98             :   :type '(choice number (const :tag "No preview unless requested" nil))
      99             :   :group 'register)
     100             : 
     101             : (defun get-register (register)
     102             :   "Return contents of Emacs register named REGISTER, or nil if none."
     103           0 :   (alist-get register register-alist))
     104             : 
     105             : (defun set-register (register value)
     106             :   "Set contents of Emacs register named REGISTER to VALUE.  Returns VALUE.
     107             : See the documentation of the variable `register-alist' for possible VALUEs."
     108           0 :   (setf (alist-get register register-alist) value))
     109             : 
     110             : (defun register-describe-oneline (c)
     111             :   "One-line description of register C."
     112           0 :   (let ((d (replace-regexp-in-string
     113             :             "\n[ \t]*" " "
     114           0 :             (with-output-to-string (describe-register-1 c)))))
     115           0 :     (if (string-match "Register.+? contains \\(?:an? \\|the \\)?" d)
     116           0 :         (substring d (match-end 0))
     117           0 :       d)))
     118             : 
     119             : (defun register-preview-default (r)
     120             :   "Default function for the variable `register-preview-function'."
     121           0 :   (format "%s: %s\n"
     122           0 :           (single-key-description (car r))
     123           0 :           (register-describe-oneline (car r))))
     124             : 
     125             : (defvar register-preview-function #'register-preview-default
     126             :   "Function to format a register for previewing.
     127             : Takes one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
     128             : Returns a string.")
     129             : 
     130             : (defun register-preview (buffer &optional show-empty)
     131             :   "Pop up a window to show register preview in BUFFER.
     132             : If SHOW-EMPTY is non-nil show the window even if no registers.
     133             : Format of each entry is controlled by the variable `register-preview-function'."
     134           0 :   (when (or show-empty (consp register-alist))
     135           0 :     (with-current-buffer-window
     136           0 :      buffer
     137           0 :      (cons 'display-buffer-below-selected
     138             :            '((window-height . fit-window-to-buffer)
     139           0 :              (preserve-size . (nil . t))))
     140             :      nil
     141           0 :      (with-current-buffer standard-output
     142           0 :        (setq cursor-in-non-selected-windows nil)
     143           0 :        (insert (mapconcat register-preview-function register-alist ""))))))
     144             : 
     145             : (defun register-read-with-preview (prompt)
     146             :   "Read and return a register name, possibly showing existing registers.
     147             : Prompt with the string PROMPT.  If `register-alist' and
     148             : `register-preview-delay' are both non-nil, display a window
     149             : listing existing registers after `register-preview-delay' seconds.
     150             : If `help-char' (or a member of `help-event-list') is pressed,
     151             : display such a window regardless."
     152           0 :   (let* ((buffer "*Register Preview*")
     153           0 :          (timer (when (numberp register-preview-delay)
     154           0 :                   (run-with-timer register-preview-delay nil
     155             :                                   (lambda ()
     156           0 :                                     (unless (get-buffer-window buffer)
     157           0 :                                       (register-preview buffer))))))
     158           0 :          (help-chars (cl-loop for c in (cons help-char help-event-list)
     159           0 :                               when (not (get-register c))
     160           0 :                               collect c)))
     161           0 :     (unwind-protect
     162           0 :         (progn
     163           0 :           (while (memq (read-key (propertize prompt 'face 'minibuffer-prompt))
     164           0 :                        help-chars)
     165           0 :             (unless (get-buffer-window buffer)
     166           0 :               (register-preview buffer 'show-empty)))
     167           0 :           (when (or (eq ?\C-g last-input-event)
     168           0 :                     (eq 'escape last-input-event)
     169           0 :                     (eq ?\C-\[ last-input-event))
     170           0 :             (keyboard-quit))
     171           0 :           (if (characterp last-input-event) last-input-event
     172           0 :             (error "Non-character input-event")))
     173           0 :       (and (timerp timer) (cancel-timer timer))
     174           0 :       (let ((w (get-buffer-window buffer)))
     175           0 :         (and (window-live-p w) (delete-window w)))
     176           0 :       (and (get-buffer buffer) (kill-buffer buffer)))))
     177             : 
     178             : (defun point-to-register (register &optional arg)
     179             :   "Store current location of point in register REGISTER.
     180             : With prefix argument, store current frame configuration.
     181             : Use \\[jump-to-register] to go to that location or restore that configuration.
     182             : Argument is a character, naming the register.
     183             : 
     184             : Interactively, reads the register using `register-read-with-preview'."
     185           0 :   (interactive (list (register-read-with-preview "Point to register: ")
     186           0 :                      current-prefix-arg))
     187             :   ;; Turn the marker into a file-ref if the buffer is killed.
     188           0 :   (add-hook 'kill-buffer-hook 'register-swap-out nil t)
     189           0 :   (set-register register
     190           0 :                 (if arg (list (current-frame-configuration) (point-marker))
     191           0 :                   (point-marker))))
     192             : 
     193             : (defun window-configuration-to-register (register &optional _arg)
     194             :   "Store the window configuration of the selected frame in register REGISTER.
     195             : Use \\[jump-to-register] to restore the configuration.
     196             : Argument is a character, naming the register.
     197             : 
     198             : Interactively, reads the register using `register-read-with-preview'."
     199           0 :   (interactive (list (register-read-with-preview
     200           0 :                       "Window configuration to register: ")
     201           0 :                      current-prefix-arg))
     202             :   ;; current-window-configuration does not include the value
     203             :   ;; of point in the current buffer, so record that separately.
     204           0 :   (set-register register (list (current-window-configuration) (point-marker))))
     205             : 
     206             : ;; It has had the optional arg for ages, but never used it.
     207             : (set-advertised-calling-convention 'window-configuration-to-register
     208             :                                    '(register) "24.4")
     209             : 
     210             : (defun frame-configuration-to-register (register &optional _arg)
     211             :   "Store the window configuration of all frames in register REGISTER.
     212             : Use \\[jump-to-register] to restore the configuration.
     213             : Argument is a character, naming the register.
     214             : 
     215             : Interactively, reads the register using `register-read-with-preview'."
     216           0 :   (interactive (list (register-read-with-preview
     217           0 :                       "Frame configuration to register: ")
     218           0 :                      current-prefix-arg))
     219             :   ;; current-frame-configuration does not include the value
     220             :   ;; of point in the current buffer, so record that separately.
     221           0 :   (set-register register (list (current-frame-configuration) (point-marker))))
     222             : 
     223             : ;; It has had the optional arg for ages, but never used it.
     224             : (set-advertised-calling-convention 'frame-configuration-to-register
     225             :                                    '(register) "24.4")
     226             : 
     227             : (make-obsolete 'frame-configuration-to-register 'frameset-to-register "24.4")
     228             : 
     229             : (defalias 'register-to-point 'jump-to-register)
     230             : (defun jump-to-register (register &optional delete)
     231             :   "Move point to location stored in a register.
     232             : If the register contains a file name, find that file.
     233             : \(To put a file name in a register, you must use `set-register'.)
     234             : If the register contains a window configuration (one frame) or a frameset
     235             : \(all frames), restore that frame or all frames accordingly.
     236             : First argument is a character, naming the register.
     237             : Optional second arg non-nil (interactively, prefix argument) says to
     238             : delete any existing frames that the frameset doesn't mention.
     239             : \(Otherwise, these frames are iconified.)
     240             : 
     241             : Interactively, reads the register using `register-read-with-preview'."
     242           0 :   (interactive (list (register-read-with-preview "Jump to register: ")
     243           0 :                      current-prefix-arg))
     244           0 :   (let ((val (get-register register)))
     245           0 :     (cond
     246           0 :      ((registerv-p val)
     247           0 :       (cl-assert (registerv-jump-func val) nil
     248             :               "Don't know how to jump to register %s"
     249           0 :               (single-key-description register))
     250           0 :       (funcall (registerv-jump-func val) (registerv-data val)))
     251           0 :      ((and (consp val) (frame-configuration-p (car val)))
     252           0 :       (set-frame-configuration (car val) (not delete))
     253           0 :       (goto-char (cadr val)))
     254           0 :      ((and (consp val) (window-configuration-p (car val)))
     255           0 :       (set-window-configuration (car val))
     256           0 :       (goto-char (cadr val)))
     257           0 :      ((markerp val)
     258           0 :       (or (marker-buffer val)
     259           0 :           (user-error "That register's buffer no longer exists"))
     260           0 :       (switch-to-buffer (marker-buffer val))
     261           0 :       (unless (or (= (point) (marker-position val))
     262           0 :                   (eq last-command 'jump-to-register))
     263           0 :         (push-mark))
     264           0 :       (goto-char val))
     265           0 :      ((and (consp val) (eq (car val) 'file))
     266           0 :       (find-file (cdr val)))
     267           0 :      ((and (consp val) (eq (car val) 'file-query))
     268           0 :       (or (find-buffer-visiting (nth 1 val))
     269           0 :           (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
     270           0 :           (user-error "Register access aborted"))
     271           0 :       (find-file (nth 1 val))
     272           0 :       (goto-char (nth 2 val)))
     273             :      (t
     274           0 :       (user-error "Register doesn't contain a buffer position or configuration")))))
     275             : 
     276             : (defun register-swap-out ()
     277             :   "Turn markers into file-query references when a buffer is killed."
     278           0 :   (and buffer-file-name
     279           0 :        (dolist (elem register-alist)
     280           0 :          (and (markerp (cdr elem))
     281           0 :               (eq (marker-buffer (cdr elem)) (current-buffer))
     282           0 :               (setcdr elem
     283           0 :                       (list 'file-query
     284           0 :                             buffer-file-name
     285           0 :                             (marker-position (cdr elem))))))))
     286             : 
     287             : (defun number-to-register (number register)
     288             :   "Store a number in a register.
     289             : Two args, NUMBER and REGISTER (a character, naming the register).
     290             : If NUMBER is nil, a decimal number is read from the buffer starting
     291             : at point, and point moves to the end of that number.
     292             : Interactively, NUMBER is the prefix arg (none means nil).
     293             : 
     294             : Interactively, reads the register using `register-read-with-preview'."
     295           0 :   (interactive (list current-prefix-arg
     296           0 :                      (register-read-with-preview "Number to register: ")))
     297           0 :   (set-register register
     298           0 :                 (if number
     299           0 :                     (prefix-numeric-value number)
     300           0 :                   (if (looking-at "\\s-*-?[0-9]+")
     301           0 :                       (progn
     302           0 :                         (goto-char (match-end 0))
     303           0 :                         (string-to-number (match-string 0)))
     304           0 :                     0))))
     305             : 
     306             : (defun increment-register (prefix register)
     307             :   "Augment contents of REGISTER.
     308             : Interactively, PREFIX is in raw form.
     309             : 
     310             : If REGISTER contains a number, add `prefix-numeric-value' of
     311             : PREFIX to it.
     312             : 
     313             : If REGISTER is empty or if it contains text, call
     314             : `append-to-register' with `delete-flag' set to PREFIX.
     315             : 
     316             : Interactively, reads the register using `register-read-with-preview'."
     317           0 :   (interactive (list current-prefix-arg
     318           0 :                      (register-read-with-preview "Increment register: ")))
     319           0 :   (let ((register-val (get-register register)))
     320           0 :     (cond
     321           0 :      ((numberp register-val)
     322           0 :       (let ((number (prefix-numeric-value prefix)))
     323           0 :         (set-register register (+ number register-val))))
     324           0 :      ((or (not register-val) (stringp register-val))
     325           0 :       (append-to-register register (region-beginning) (region-end) prefix))
     326           0 :      (t (user-error "Register does not contain a number or text")))))
     327             : 
     328             : (defun view-register (register)
     329             :   "Display what is contained in register named REGISTER.
     330             : The Lisp value REGISTER is a character.
     331             : 
     332             : Interactively, reads the register using `register-read-with-preview'."
     333           0 :   (interactive (list (register-read-with-preview "View register: ")))
     334           0 :   (let ((val (get-register register)))
     335           0 :     (if (null val)
     336           0 :         (message "Register %s is empty" (single-key-description register))
     337           0 :       (with-output-to-temp-buffer "*Output*"
     338           0 :         (describe-register-1 register t)))))
     339             : 
     340             : (defun list-registers ()
     341             :   "Display a list of nonempty registers saying briefly what they contain."
     342             :   (interactive)
     343           0 :   (let ((list (copy-sequence register-alist)))
     344           0 :     (setq list (sort list (lambda (a b) (< (car a) (car b)))))
     345           0 :     (with-output-to-temp-buffer "*Output*"
     346           0 :       (dolist (elt list)
     347           0 :         (when (get-register (car elt))
     348           0 :           (describe-register-1 (car elt))
     349           0 :           (terpri))))))
     350             : 
     351             : (defun describe-register-1 (register &optional verbose)
     352           0 :   (princ "Register ")
     353           0 :   (princ (single-key-description register))
     354           0 :   (princ " contains ")
     355           0 :   (let ((val (get-register register)))
     356           0 :     (cond
     357           0 :      ((registerv-p val)
     358           0 :       (if (registerv-print-func val)
     359           0 :           (funcall (registerv-print-func val) (registerv-data val))
     360           0 :         (princ "[UNPRINTABLE CONTENTS].")))
     361             : 
     362           0 :      ((numberp val)
     363           0 :       (princ val))
     364             : 
     365           0 :      ((markerp val)
     366           0 :       (let ((buf (marker-buffer val)))
     367           0 :         (if (null buf)
     368           0 :             (princ "a marker in no buffer")
     369           0 :           (princ "a buffer position:\n    buffer ")
     370           0 :           (princ (buffer-name buf))
     371           0 :           (princ ", position ")
     372           0 :           (princ (marker-position val)))))
     373             : 
     374           0 :      ((and (consp val) (window-configuration-p (car val)))
     375           0 :       (princ "a window configuration."))
     376             : 
     377           0 :      ((and (consp val) (frame-configuration-p (car val)))
     378           0 :       (princ "a frame configuration."))
     379             : 
     380           0 :      ((and (consp val) (eq (car val) 'file))
     381           0 :       (princ "the file ")
     382           0 :       (prin1 (cdr val))
     383           0 :       (princ "."))
     384             : 
     385           0 :      ((and (consp val) (eq (car val) 'file-query))
     386           0 :       (princ "a file-query reference:\n    file ")
     387           0 :       (prin1 (car (cdr val)))
     388           0 :       (princ ",\n    position ")
     389           0 :       (princ (car (cdr (cdr val))))
     390           0 :       (princ "."))
     391             : 
     392           0 :      ((consp val)
     393           0 :       (if verbose
     394           0 :           (progn
     395           0 :             (princ "the rectangle:\n")
     396           0 :             (while val
     397           0 :               (princ "    ")
     398           0 :               (princ (car val))
     399           0 :               (terpri)
     400           0 :               (setq val (cdr val))))
     401           0 :         (princ "a rectangle starting with ")
     402           0 :         (princ (car val))))
     403             : 
     404           0 :      ((stringp val)
     405           0 :       (setq val (copy-sequence val))
     406           0 :       (if (eq yank-excluded-properties t)
     407           0 :           (set-text-properties 0 (length val) nil val)
     408           0 :         (remove-list-of-text-properties 0 (length val)
     409           0 :                                         yank-excluded-properties val))
     410           0 :       (if verbose
     411           0 :           (progn
     412           0 :             (princ "the text:\n")
     413           0 :             (princ val))
     414           0 :         (cond
     415             :          ;; Extract first N characters starting with first non-whitespace.
     416           0 :          ((string-match (format "[^ \t\n].\\{,%d\\}"
     417             :                                 ;; Deduct 6 for the spaces inserted below.
     418           0 :                                 (min 20 (max 0 (- (window-width) 6))))
     419           0 :                         val)
     420           0 :           (princ "text starting with\n    ")
     421           0 :           (princ (match-string 0 val)))
     422           0 :          ((string-match "^[ \t\n]+$" val)
     423           0 :           (princ "whitespace"))
     424             :          (t
     425           0 :           (princ "the empty string")))))
     426             :      (t
     427           0 :       (princ "Garbage:\n")
     428           0 :       (if verbose (prin1 val))))))
     429             : 
     430             : (defun insert-register (register &optional arg)
     431             :   "Insert contents of register REGISTER.  (REGISTER is a character.)
     432             : Normally puts point before and mark after the inserted text.
     433             : If optional second arg is non-nil, puts mark before and point after.
     434             : Interactively, second arg is nil if prefix arg is supplied and t
     435             : otherwise.
     436             : 
     437             : Interactively, reads the register using `register-read-with-preview'."
     438           0 :   (interactive (progn
     439           0 :                  (barf-if-buffer-read-only)
     440           0 :                  (list (register-read-with-preview "Insert register: ")
     441           0 :                        (not current-prefix-arg))))
     442           0 :   (push-mark)
     443           0 :   (let ((val (get-register register)))
     444           0 :     (cond
     445           0 :      ((registerv-p val)
     446           0 :       (cl-assert (registerv-insert-func val) nil
     447             :               "Don't know how to insert register %s"
     448           0 :               (single-key-description register))
     449           0 :       (funcall (registerv-insert-func val) (registerv-data val)))
     450           0 :      ((consp val)
     451           0 :       (insert-rectangle val))
     452           0 :      ((stringp val)
     453           0 :       (insert-for-yank val))
     454           0 :      ((numberp val)
     455           0 :       (princ val (current-buffer)))
     456           0 :      ((and (markerp val) (marker-position val))
     457           0 :       (princ (marker-position val) (current-buffer)))
     458             :      (t
     459           0 :       (user-error "Register does not contain text"))))
     460           0 :   (if (not arg) (exchange-point-and-mark)))
     461             : 
     462             : (defun copy-to-register (register start end &optional delete-flag region)
     463             :   "Copy region into register REGISTER.
     464             : With prefix arg, delete as well.
     465             : Called from program, takes five args: REGISTER, START, END, DELETE-FLAG,
     466             : and REGION.  START and END are buffer positions indicating what to copy.
     467             : The optional argument REGION if non-nil, indicates that we're not just
     468             : copying some text between START and END, but we're copying the region.
     469             : 
     470             : Interactively, reads the register using `register-read-with-preview'."
     471           0 :   (interactive (list (register-read-with-preview "Copy to register: ")
     472           0 :                      (region-beginning)
     473           0 :                      (region-end)
     474           0 :                      current-prefix-arg
     475           0 :                      t))
     476           0 :   (set-register register (if region
     477           0 :                              (funcall region-extract-function delete-flag)
     478           0 :                            (prog1 (filter-buffer-substring start end)
     479           0 :                              (if delete-flag (delete-region start end)))))
     480           0 :   (setq deactivate-mark t)
     481           0 :   (cond (delete-flag)
     482           0 :         ((called-interactively-p 'interactive)
     483           0 :          (indicate-copied-region))))
     484             : 
     485             : (defun append-to-register (register start end &optional delete-flag)
     486             :   "Append region to text in register REGISTER.
     487             : With prefix arg, delete as well.
     488             : Called from program, takes four args: REGISTER, START, END and DELETE-FLAG.
     489             : START and END are buffer positions indicating what to append.
     490             : 
     491             : Interactively, reads the register using `register-read-with-preview'."
     492           0 :   (interactive (list (register-read-with-preview "Append to register: ")
     493           0 :                      (region-beginning)
     494           0 :                      (region-end)
     495           0 :                      current-prefix-arg))
     496           0 :   (let ((reg (get-register register))
     497           0 :         (text (filter-buffer-substring start end))
     498           0 :         (separator (and register-separator (get-register register-separator))))
     499           0 :     (set-register
     500           0 :      register (cond ((not reg) text)
     501           0 :                     ((stringp reg) (concat reg separator text))
     502           0 :                     (t (user-error "Register does not contain text")))))
     503           0 :   (setq deactivate-mark t)
     504           0 :   (cond (delete-flag
     505           0 :          (delete-region start end))
     506           0 :         ((called-interactively-p 'interactive)
     507           0 :          (indicate-copied-region))))
     508             : 
     509             : (defun prepend-to-register (register start end &optional delete-flag)
     510             :   "Prepend region to text in register REGISTER.
     511             : With prefix arg, delete as well.
     512             : Called from program, takes four args: REGISTER, START, END and DELETE-FLAG.
     513             : START and END are buffer positions indicating what to prepend.
     514             : 
     515             : Interactively, reads the register using `register-read-with-preview'."
     516           0 :   (interactive (list (register-read-with-preview "Prepend to register: ")
     517           0 :                      (region-beginning)
     518           0 :                      (region-end)
     519           0 :                      current-prefix-arg))
     520           0 :   (let ((reg (get-register register))
     521           0 :         (text (filter-buffer-substring start end))
     522           0 :         (separator (and register-separator (get-register register-separator))))
     523           0 :     (set-register
     524           0 :      register (cond ((not reg) text)
     525           0 :                     ((stringp reg) (concat text separator reg))
     526           0 :                     (t (user-error "Register does not contain text")))))
     527           0 :   (setq deactivate-mark t)
     528           0 :   (cond (delete-flag
     529           0 :          (delete-region start end))
     530           0 :         ((called-interactively-p 'interactive)
     531           0 :          (indicate-copied-region))))
     532             : 
     533             : (defun copy-rectangle-to-register (register start end &optional delete-flag)
     534             :   "Copy rectangular region into register REGISTER.
     535             : With prefix arg, delete as well.
     536             : To insert this register in the buffer, use \\[insert-register].
     537             : 
     538             : Called from a program, takes four args: REGISTER, START, END and DELETE-FLAG.
     539             : START and END are buffer positions giving two corners of rectangle.
     540             : 
     541             : Interactively, reads the register using `register-read-with-preview'."
     542           0 :   (interactive (list (register-read-with-preview
     543           0 :                       "Copy rectangle to register: ")
     544           0 :                      (region-beginning)
     545           0 :                      (region-end)
     546           0 :                      current-prefix-arg))
     547           0 :   (let ((rectangle (if delete-flag
     548           0 :                        (delete-extract-rectangle start end)
     549           0 :                      (extract-rectangle start end))))
     550           0 :     (set-register register rectangle)
     551           0 :     (when (and (null delete-flag)
     552           0 :                (called-interactively-p 'interactive))
     553           0 :       (setq deactivate-mark t)
     554           0 :       (indicate-copied-region (length (car rectangle))))))
     555             : 
     556             : (provide 'register)
     557             : ;;; register.el ends here

Generated by: LCOV version 1.12