1 ;;; register-list.el --- Interactively list/edit registers -*- lexical-binding:t -*-
3 ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
5 ;; Filename: register-list.el
6 ;; Author: Bastien Guerry <bzg@gnu.org>
7 ;; Maintainer: Bastien Guerry <bzg@gnu.org>
9 ;; Description: List and edit the register
12 ;; This program 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, or (at your option)
17 ;; This program 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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with this program; if not, write to the Free Software
24 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;; This is not part of GNU Emacs.
30 ;; This library lets you list and edit registers. M-x `register-list'
31 ;; displays a list of currently set registers.
33 ;; This list is similar to that of `bookmark-bmenu-list': you can set
34 ;; registers to delete with `d' and delete them with `x'. If you want
35 ;; to concatenate the content of registers, mark them with `c' and
38 ;; You can also edit the register's key with `k' and its value with `v'
39 ;; Hitting RET on a value string will jump to the register's location or
40 ;; add the text to the kill ring. Hitting RET on a register's type will
41 ;; restrict the list to registers of this type.
43 ;; Put this file into your load-path and the following into your ~/.emacs:
44 ;; (require 'register-list)
48 ;; - better sorting (interactive)
49 ;; - overlay register when deleting duplicates
50 ;; - more useful message when selecting a type
51 ;; - concatenation -> merge
52 ;; - support merging rectangles
53 ;; - add numbers when "merging" them
54 ;; - C-k to kill a register
58 ;; - [2008-03-09] Released v0.1
59 ;; http://article.gmane.org/gmane.emacs.sources/2832
66 (defgroup register-list nil
67 "Interactively list/edit registers."
71 (defcustom register-list-string-width nil
72 "Maximum width for the register value string."
75 (defcustom register-list-preserve-fontification nil
76 "Non-nil means keep the value strings fontified."
79 (defcustom register-list-default-types "[FNMRSW]"
80 "A regexp matching the default register types to list.
82 The available types are: [F]rame [N]umber [M]arkers [R]ectangle
83 \[S]string and [W]window. [FW] will list markers, frame and
84 window configuration, [SM] will list strings and markers, etc."
87 (defface register-list-off-rectangle
88 '((t (:inverse-video t)))
89 "Face used to show what falls out of a rectangle.")
91 ;;; Variables, map, mode
93 (defvar register-list-mode-map
94 (let ((map (make-keymap)))
95 (suppress-keymap map t)
96 (define-key map "q" 'quit-window)
97 (define-key map "Q" 'register-list-quit)
98 (define-key map [(tab)] 'register-list-tab)
99 (define-key map "d" 'register-list-mark-delete)
100 (define-key map "D" 'register-list-delete-duplicates)
101 (define-key map "c" 'register-list-mark-concat)
102 (define-key map "x" 'register-list-execute)
103 (define-key map "+" 'register-list-increment-key)
104 (define-key map "-" 'register-list-decrement-key)
105 (define-key map "e" 'register-list-edit-key)
106 (define-key map "E" 'register-list-edit-value)
107 (define-key map "f" 'register-list-toggle-fontification)
108 (define-key map " " 'next-line)
109 (define-key map "n" 'next-line)
110 (define-key map "p" 'previous-line)
111 (define-key map "u" 'register-list-unmark)
112 (define-key map "U" 'register-list-unmark-all)
113 (define-key map "g" 'register-list-refresh)
115 (lambda () (interactive) (register-list-refresh "F")))
117 (lambda () (interactive) (register-list-refresh "N")))
119 (lambda () (interactive) (register-list-refresh "M")))
121 (lambda () (interactive) (register-list-refresh "R")))
123 (lambda () (interactive) (register-list-refresh "S")))
125 (lambda () (interactive) (register-list-refresh "W")))
127 (lambda() (interactive) (register-list-refresh "[FNMRSW]")))
128 (define-key map "?" 'describe-mode)
130 (define-key map [follow-link] 'mouse-face)
131 (define-key map [mouse-2] 'register-list-call-handler-at-mouse)
132 (define-key map [(return)] 'register-list-call-handler-at-point)
134 "Keymap for `register-list-mode'.")
135 (defvar register-list-edit-value-mode-map
136 (let ((map (make-sparse-keymap)))
137 (define-key map (kbd "C-c C-c") 'register-list-send-value)
139 "Keymap for editing the value of a register.")
140 (defvar register-list-current-type nil
141 "The current type for the register menu.")
142 (defvar register-list-current-fontification nil
143 "Whether the value strings are currently fontified.")
144 (defvar register-list-temp-pos nil
145 "Temporary store the line the cursor is on.")
146 (defvar register-list-temp-window-cfg nil
147 "Temporary window configuration.
148 Saved before editing the value of a register.")
149 (defvar register-list-temp-register nil
150 "Temporary value of the edited register.")
151 (defvar register-list-edit-value-type nil
152 "The type of the edited value.")
153 (defvar register-list-rectangle-column nil
154 "End of a rectangle line.")
158 (defmacro register-list-preserve-pos (force-line &rest body)
159 "Preserve the position and execute BODY.
160 If FORCE-LINE is non-nil, force moving to this line."
161 (declare (debug t) (indent 1))
162 `(let (,@(unless force-line '((line (line-number-at-pos (point)))))
163 (col (current-column)))
165 (goto-char (point-min))
166 (forward-line ,(or force-line '(1- line)))
167 (line-move-to-column col)))
169 (defmacro register-list-map-lines (let-vals &rest body)
170 "Execute BODY inside a let form with LET-VALS on all lines."
172 (goto-char (point-min))
178 (defvar register-list-concat-separator "\n"
179 "Default separator when merging.")
181 (defvar register-list-concat-key-select 'last)
183 ;; FIXME skip rectangle (or handle them separatly
184 (defun register-list-execute nil
185 "Delete/concatenate registers marker for deletion/concatenation."
187 (let ((line (line-number-at-pos (point))) newreg concat)
188 (goto-char (point-min))
189 (while (re-search-forward "^[DC]" nil t)
190 (let* ((reg-point (next-single-property-change (point) 'register))
191 (reg (get-text-property reg-point 'register)))
192 (if (string= (match-string 0) "D")
193 (setq register-alist (delete reg register-alist))
196 ;; set the new register
198 (cons (cond ((eq register-list-concat-key-select 'first)
200 ((eq register-list-concat-key-select 'last)
201 (caar (reverse concat)))
204 (mapconcat (lambda(x) (char-to-string (car x)))
206 (mapconcat (lambda (i) (cdr i)) (reverse concat)
207 (cond ((eq register-list-concat-separator 'ask)
208 (read-from-minibuffer "Separator: "))
209 ((stringp register-list-concat-separator)
210 register-list-concat-separator)
212 ;; delete old registers
214 (setq register-alist (delete r register-alist)))
215 ;; push the new register
216 (push newreg register-alist))
217 (register-list register-list-current-type
218 register-list-current-fontification)
219 ;; move the cursor back
220 (goto-char (point-min))
221 (line-move (- line 2) t)))
223 (defconst register-list--intangible
224 (if (fboundp 'cursor-intangible-mode)
225 'cursor-intangible 'intangible))
227 (defun register-list-set-mark (mark)
228 "Set mark at the beginning of the line."
229 (let ((inhibit-read-only t))
231 (unless (get-text-property (point) register-list--intangible)
233 (save-excursion (insert mark))
234 (unless (save-excursion (forward-line 1) (eobp))
237 (defun register-list-mark-delete nil
238 "Mark the register at point for deletion."
240 (register-list-set-mark "D"))
242 (defun register-list-mark-concat nil
243 "Mark the register at point for further concatenation."
245 (register-list-set-mark "C"))
247 (defun register-list-unmark nil
248 "Unmark the register at point."
250 (register-list-set-mark " "))
252 (defun register-list-unmark-all nil
253 "Unmark all registers."
255 (let ((inhibit-read-only t))
257 (goto-char (point-min))
259 (while (and (forward-line 1) (not (eobp)))
263 (defun register-list-refresh (&optional type)
264 "Refresh the list of registers.
265 An optional TYPE argument restrict the list these types."
267 (register-list-preserve-pos nil
268 (register-list (or type register-list-current-type)
269 register-list-current-fontification)))
271 (defun register-list-quit nil
272 "Quit the register list and kill its buffer."
274 (kill-buffer (current-buffer)))
276 (defun register-list-toggle-fontification nil
277 "Toggle fontification of the value strings."
279 (register-list-preserve-pos nil
280 (setq register-list-current-fontification
281 (not register-list-current-fontification))
282 (register-list register-list-current-type
283 register-list-current-fontification)))
285 (define-derived-mode register-list-mode special-mode "Register List"
286 "Major mode for editing a list of register keys.
288 Each line is of the form:
290 \[Delete-flag] Key Type Value
292 The leftmost column displays a `D' character if the register key
293 is flagged for further deletion. You can add such flag by hitting
294 \\[register-list-delete].
296 The Key column displays the character used for this register.
297 Hitting \\[register-list-call-handler-at-point] on the key will
298 prompt for a replacement.
300 The Type column displays the type of the register, either [F]rame
301 \[N]umber [M]arkers [R]ectangle [S]string or [W]window. Hitting
302 \\[register-list-call-handler-at-point] on this column will
303 restrict the register list to this type of registers. To quickly
304 list a specific type, hit the type character among [FNMRSW].
306 The Value column displays information about the value of the
307 register: either a string if the register's value is a string, a
308 number or a rectangle, or the location of the marker or some
309 information about window and frame configuration. Hitting
310 \\[register-list-call-handler-at-point] on this column will
311 copy the string to the kill ring or jump to the location.
313 \\[register-list-edit-key] -- edit the key for this register.
314 \\[register-list-edit-value] -- edit the value for this register.
315 \\[register-list-increment-key] -- increment key at point.
316 \\[register-list-decrement-key] -- decrement key at point.
317 \\[register-list-mark-delete] -- mark the register at point for deletion.
318 \\[register-list-mark-concat] -- mark the register at point for concatenation.
319 \\[register-list-unmark] -- unmark the register at point.
320 \\[register-list-unmark-all] -- unmark all registers.
321 \\[register-list-execute] -- execute deletions or concatenations.
322 \\[register-list-toggle-fontification] -- toggle fontification of value strings.
323 \\[register-list-refresh] -- refresh the register menu display.
324 \\[register-list-tab] -- cycle between the key, the type and the value.
325 \\[register-list-quit] -- quit the register menu."
326 (setq truncate-lines t)
327 (if (fboundp 'cursor-intangible-mode) (cursor-intangible-mode 1))
328 (setq buffer-read-only t))
330 ;;\\[register-list-edit-key-or-value] -- edit the key for this register.
332 (defun register-list-tab nil
333 "Cycle between the register key, the type and the value."
335 (let* ((eol (save-excursion (end-of-line) (point)))
336 (m-f-chg (next-single-property-change (point) 'mouse-face nil eol))
337 (m-f-pos (text-property-any m-f-chg eol 'mouse-face 'highlight))
338 (r-f-chg (next-single-property-change (point) 'register nil eol))
339 (r-f-prop (get-text-property r-f-chg 'register)) point)
340 (cond (r-f-prop (goto-char r-f-chg))
341 (m-f-pos (goto-char m-f-pos))
342 (t (beginning-of-line 2)
343 (if (setq point (next-single-property-change
345 (goto-char point))))))
348 (defun register-list (&optional type fontify)
349 "Display a list of registers.
350 An optional argument TYPE defines a regexp to restrict the
351 register menu to. A second optional argument FONTIFICATION
352 decides if the display preserves original fontification for
355 The default types are defined in `register-list-default-types',
358 The list is displayed in a buffer named `*Register List*' in
359 `register-list-mode', which see."
361 (switch-to-buffer (get-buffer-create "*Register List*"))
362 (let ((inhibit-read-only t))
363 (setq type (or type register-list-default-types))
364 (setq register-list-current-fontification
365 (or fontify register-list-preserve-fontification))
366 (setq register-list-current-type type)
368 (setq register-alist ;; TODO better sorting.
369 (sort register-alist (lambda (a b) (< (car a) (car b)))))
371 ;; FIXME: Why intangible?
372 (insert (concat (propertize "% Key Type Value\n"
373 'face 'font-lock-type-face
374 register-list--intangible t) ;; 'front-sticky t)
375 (propertize "- --- ---- -----\n"
376 register-list--intangible t
377 'face 'font-lock-comment-delimiter-face)))
378 (dolist (register register-alist)
379 (let* ((key (char-to-string (car register)))
381 (typ (register-list-get-type val))
382 (hdl (register-list-get-handler register typ)))
383 (when (string-match typ type)
385 (format " %s %s %s\n"
386 (propertize key 'face 'bold 'register register
387 'register-handler hdl)
388 (propertize (concat "[" typ "]")
389 'mouse-face 'highlight
390 'help-echo "mouse-2: restrict to this type"
393 (register-list-preserve-pos nil
395 typ register-list-current-fontification))))
396 (propertize (register-list-prepare-string
397 (register-list-value-to-string val typ) fontify)
398 'mouse-face 'highlight
399 'register-handler hdl
400 'help-echo "mouse-2: use this register")))))))
402 (goto-char (point-min))
404 (if (called-interactively-p 'interactive)
405 (message "[d]elete [e/E]dit key/value RET:jump/copy [FNRSW]:select type ?:help")
406 (message "Register type: %s" register-list-current-type)))
408 (defun register-list-call-handler-at-mouse (ev)
409 "Call the register handler at point.
410 See `register-list-call-handler-at-point' for details."
413 (register-list-call-handler-at-point))
415 (defun register-list-call-handler-at-point nil
416 "Call the register handler at point.
417 If the point is on a register key, edit the key. If the point is
418 on a register type, rebuild the list restricting to registers of
419 this type. If the point is on a register value, either jump to
420 the register or copy its value into the kill ring."
422 (let ((handler (get-text-property (point) 'register-handler)))
425 (funcall (get-text-property (point) 'register-handler))
426 (error (message "Can't jump to register location"))))))
428 (defun register-list-get-handler (register type)
429 "Return a handler function for a REGISTER with TYPE."
430 (cond ((string= "?" type)
431 `(lambda() (message "No action with this type")))
434 (kill-new ,(cdr register))
435 (message "String copied to the kill ring")))
438 (kill-new ,(number-to-string (cdr register)))
439 (message "Number copied to the kill ring as a string")))
442 (kill-new ,(mapconcat 'identity (cdr register) "\n"))
443 (message "Rectangle copied to the kill ring")))
444 ((string-match "[FMW]" type)
446 (jump-to-register ,(car register))
447 (message (format "Jumped to register %s"
448 ,(char-to-string (car register))))))))
450 (defun register-list-value-to-string (value type)
451 "Convert a register VALUE into a string according to its TYPE."
452 (cond ((string= "M" type)
453 (cond ((marker-position value)
454 (format "[Marker at point %d in buffer %s]"
455 (marker-position value)
456 (buffer-name (marker-buffer value))))
457 ((marker-buffer value)
458 (format "[Marker in buffer %s]"
459 (buffer-name (marker-buffer value))))
460 (t (format "[Marker gone?]"))))
462 (format "Number: %s" (number-to-string value)))
464 (replace-regexp-in-string "[\n\r\t]" " " value))
466 (mapconcat 'identity value "\\ "))
468 (format "[Window configuration in frame \"%s\"]"
470 (window-configuration-frame (car value)) 'name)))
472 (format "[Frame configuration]"))
473 (t "[Error: unknow type]")))
475 (defun register-list-get-type (key)
476 "Get the type for register's KEY."
478 (cond ((stringp key) "S")
482 (cond ((window-configuration-p (car key)) "W")
483 ((frame-configuration-p (car key)) "F")
484 ((stringp (car key)) "R")
485 ((string= "Unprintable entity" (car key)) "?")
488 ;;; Edit key/value of the register
491 ;; (defun register-list-edit-key-or-value nil
492 ;; "Edit the register key or value depending on the point."
494 ;; (if (get-text-property (point) 'register)
495 ;; (register-list-edit-key)
496 ;; (register-list-edit-value)))
498 (defun register-list-edit-key nil
499 "Edit the key of the register at point."
501 (register-list-set-key
502 (lambda (v) (read-char (format "New key (%s): "
503 (char-to-string v))))))
505 (defun register-list-increment-key nil
506 "Increment the key of the register at point."
508 (register-list-set-key '1+))
510 (defun register-list-delete-duplicates nil
511 "Interactively delete duplicates."
515 (if (and (eq (car r) (car rr))
517 (format "Delete register with key `%s'? "
518 (char-to-string (car rr)))))
519 (setq register-alist (delete rr register-alist))))
520 (cdr (member r register-alist))))
523 ;; (defun register-list- (register)
524 ;; "Overline the register with KEY."
526 ;; (goto-char (point-min))
527 ;; (while (re-search-forward (concat "^[ DC]" (char-to-string key)) nil t)
529 ;; (while (next-single-property-change (point) 'register)
531 (defun register-list-decrement-key nil
532 "Decrement the key of the register at point."
534 (register-list-set-key '1-))
536 (defun register-list-set-key (function)
537 "Update the regsiter key by applying FUNCTION."
538 (register-list-preserve-pos
539 2 ;; go back to top of the sorted list
541 (let* ((reg-point (next-single-property-change (point) 'register))
542 (reg (get-text-property reg-point 'register))
544 (setq register-alist (delete reg register-alist))
545 (add-to-list 'register-alist
546 (cons (setcar reg (funcall function val)) (cdr reg)))
547 (register-list register-list-current-type
548 register-list-current-fontification))))
550 (defun register-list-edit-value nil
551 "Edit the value of the register at point."
556 (next-single-property-change (point) 'register)))
557 (reg (get-text-property reg-at-point 'register))
559 (if (not (or (stringp val) (numberp val)
560 (and (listp val) (stringp (car val)))))
561 (message "Can't edit this type of register")
562 (setq register-list-temp-window-cfg (current-window-configuration))
563 (setq register-list-temp-register reg)
564 (setq register-list-temp-pos
565 (cons (line-number-at-pos (point)) (current-column)))
566 (setq register-list-edit-value-type
567 (cond ((numberp val) 'number)
568 ((listp val) 'rectangle)
570 (pop-to-buffer (get-buffer-create "*Register Edit*"))
572 (insert (cond ((numberp val) (number-to-string val))
573 ((listp val) (mapconcat 'identity val "\n"))
575 (setq register-list-rectangle-column
576 (if (eq register-list-edit-value-type 'rectangle)
577 (length (car val)) nil))
578 (register-list-edit-value-mode)
579 (message "Press C-c C-c when you're done"))))
581 (define-derived-mode register-list-edit-value-mode text-mode
582 "Edit Register Value"
583 "Mode for editing the value of a register.
584 When you are done editing the value, store it with \\[register-list-send-string].
586 \\{register-list-edit-value-mode-map}")
588 (defun register-list-add-rectangle-overlays (column)
589 "Add overlays to display strings beyond COLUMN.
590 Do this on all lines in the current buffer."
591 (register-list-map-lines
592 ((beg (progn (forward-char column) (point)))
593 (end (progn (end-of-line) (point))))
595 (overlay-put (make-overlay beg end)
596 'face 'register-list-off-rectangle))))
598 (defun register-list-add-trailing-whitespace (column)
599 "Add trailing whitespaces to fill to COLUMN.
600 Do this on all lines in the current buffer."
601 (register-list-map-lines
602 ((eol (save-excursion (end-of-line) (point)))
603 (rem (% eol (1+ column))))
604 (if (and (not (eq rem 0))
605 (< eol (* (1+ column) (line-number-at-pos (point)))))
608 (insert (make-string (- (1+ column) rem) 32))))))
610 (defun register-list-send-value nil
611 "Use the buffer to store the new value of a register.
612 Convert the buffer to a number or a rectangle if required."
615 (when register-list-rectangle-column
616 ;; fix whitespace before sending a rectangle
617 (register-list-add-trailing-whitespace
618 register-list-rectangle-column)
619 ;; cut off trailing string before sending a rectangle
620 (register-list-add-rectangle-overlays
621 register-list-rectangle-column)
622 (if (and (delq nil (overlay-lists))
623 (not (y-or-n-p "Cut off the fontified part of the rectangle? ")))
624 (throw 'cancel (message "Back to editing"))))
625 ;; now send the value
626 (set-register (car register-list-temp-register)
627 (cond ((eq register-list-edit-value-type 'number)
628 (string-to-number (buffer-string)))
629 ((eq register-list-edit-value-type 'rectangle)
630 (mapcar (lambda (l) (truncate-string-to-width
631 l register-list-rectangle-column
633 (split-string (buffer-string) "\n")))
634 (t (buffer-string))))
635 (kill-buffer (current-buffer))
636 (register-list register-list-current-type
637 register-list-current-fontification)
638 (set-window-configuration register-list-temp-window-cfg)
639 (line-move (1- (car register-list-temp-pos)) t)
640 (line-move-to-column (cdr register-list-temp-pos)))
641 ;; remove overlays if sending was cancelled
642 (mapc (lambda(ovs) (mapc (lambda(o) (delete-overlay o)) ovs))
644 (message "New value stored"))
646 (defun register-list-prepare-string (string &optional fontify)
647 "Prepare STRING for the register list.
648 An optional argument FONTIFY takes precedence over
649 `register-list-preserve-fontification' to decide whether the
650 string should keep its original fontification. Also shorten the
651 output string to `register-list-string-width'."
652 (if (and register-list-string-width
653 (> (length string) register-list-string-width))
654 (setq string (substring string 0 register-list-string-width)))
655 (when (or fontify register-list-preserve-fontification)
656 (remove-text-properties 0 (length string) '(face nil) string))
659 (provide 'register-list)
661 ;;; register-list.el ends here