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
|