1 ;;; register-list.el --- Interactively list/edit registers -*- lexical-binding:t -*-
3 ;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
5 ;; Filename: register-list.el
6 ;; Author: Bastien Guerry <bzg AT altern DOT org>
7 ;; Maintainer: Bastien Guerry <bzg AT altern DOT 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 (defun register-list-set-mark (mark)
224 "Set mark at the beginning of the line."
225 (let ((inhibit-read-only t))
227 (unless (get-text-property (point) 'intangible)
229 (save-excursion (insert mark))
230 (unless (save-excursion (forward-line 1) (eobp))
233 (defun register-list-mark-delete nil
234 "Mark the register at point for deletion."
236 (register-list-set-mark "D"))
238 (defun register-list-mark-concat nil
239 "Mark the register at point for further concatenation."
241 (register-list-set-mark "C"))
243 (defun register-list-unmark nil
244 "Unmark the register at point."
246 (register-list-set-mark " "))
248 (defun register-list-unmark-all nil
249 "Unmark all registers."
251 (let ((inhibit-read-only t))
253 (goto-char (point-min))
255 (while (and (forward-line 1) (not (eobp)))
259 (defun register-list-refresh (&optional type)
260 "Refresh the list of registers.
261 An optional TYPE argument restrict the list these types."
263 (register-list-preserve-pos nil
264 (register-list (or type register-list-current-type)
265 register-list-current-fontification)))
267 (defun register-list-quit nil
268 "Quit the register list and kill its buffer."
270 (kill-buffer (current-buffer)))
272 (defun register-list-toggle-fontification nil
273 "Toggle fontification of the value strings."
275 (register-list-preserve-pos nil
276 (setq register-list-current-fontification
277 (not register-list-current-fontification))
278 (register-list register-list-current-type
279 register-list-current-fontification)))
281 (define-derived-mode register-list-mode special-mode "Register List"
282 "Major mode for editing a list of register keys.
284 Each line is of the form:
286 \[Delete-flag] Key Type Value
288 The leftmost column displays a `D' character if the register key
289 is flagged for further deletion. You can add such flag by hitting
290 \\[register-list-delete].
292 The Key column displays the character used for this register.
293 Hitting \\[register-list-call-handler-at-point] on the key will
294 prompt for a replacement.
296 The Type column displays the type of the register, either [F]rame
297 \[N]umber [M]arkers [R]ectangle [S]string or [W]window. Hitting
298 \\[register-list-call-handler-at-point] on this column will
299 restrict the register list to this type of registers. To quickly
300 list a specific type, hit the type character among [FNMRSW].
302 The Value column displays information about the value of the
303 register: either a string if the register's value is a string, a
304 number or a rectangle, or the location of the marker or some
305 information about window and frame configuration. Hitting
306 \\[register-list-call-handler-at-point] on this column will
307 copy the string to the kill ring or jump to the location.
309 \\[register-list-edit-key] -- edit the key for this register.
310 \\[register-list-edit-value] -- edit the value for this register.
311 \\[register-list-increment-key] -- increment key at point.
312 \\[register-list-decrement-key] -- decrement key at point.
313 \\[register-list-mark-delete] -- mark the register at point for deletion.
314 \\[register-list-mark-concat] -- mark the register at point for concatenation.
315 \\[register-list-unmark] -- unmark the register at point.
316 \\[register-list-unmark-all] -- unmark all registers.
317 \\[register-list-execute] -- execute deletions or concatenations.
318 \\[register-list-toggle-fontification] -- toggle fontification of value strings.
319 \\[register-list-refresh] -- refresh the register menu display.
320 \\[register-list-tab] -- cycle between the key, the type and the value.
321 \\[register-list-quit] -- quit the register menu."
322 (setq truncate-lines t)
323 (setq buffer-read-only t))
325 ;;\\[register-list-edit-key-or-value] -- edit the key for this register.
327 (defun register-list-tab nil
328 "Cycle between the register key, the type and the value."
330 (let* ((eol (save-excursion (end-of-line) (point)))
331 (m-f-chg (next-single-property-change (point) 'mouse-face nil eol))
332 (m-f-pos (text-property-any m-f-chg eol 'mouse-face 'highlight))
333 (r-f-chg (next-single-property-change (point) 'register nil eol))
334 (r-f-prop (get-text-property r-f-chg 'register)) point)
335 (cond (r-f-prop (goto-char r-f-chg))
336 (m-f-pos (goto-char m-f-pos))
337 (t (beginning-of-line 2)
338 (if (setq point (next-single-property-change
340 (goto-char point))))))
343 (defun register-list (&optional type fontify)
344 "Display a list of registers.
345 An optional argument TYPE defines a regexp to restrict the
346 register menu to. A second optional argument FONTIFICATION
347 decides if the display preserves original fontification for
350 The default types are defined in `register-list-default-types',
353 The list is displayed in a buffer named `*Register List*' in
354 `register-list-mode', which see."
356 (switch-to-buffer (get-buffer-create "*Register List*"))
357 (let ((inhibit-read-only t))
358 (setq type (or type register-list-default-types))
359 (setq register-list-current-fontification
360 (or fontify register-list-preserve-fontification))
361 (setq register-list-current-type type)
363 (setq register-alist ;; TODO better sorting.
364 (sort register-alist (lambda (a b) (< (car a) (car b)))))
366 ;; FIXME: Why `intangible'?
367 (insert (concat (propertize "% Key Type Value\n"
368 'face 'font-lock-type-face
369 'intangible t) ;; 'front-sticky t)
370 (propertize "- --- ---- -----\n"
372 'face 'font-lock-comment-delimiter-face)))
373 (dolist (register register-alist)
374 (let* ((key (char-to-string (car register)))
376 (typ (register-list-get-type val))
377 (hdl (register-list-get-handler register typ)))
378 (when (string-match typ type)
380 (format " %s %s %s\n"
381 (propertize key 'face 'bold 'register register
382 'register-handler hdl)
383 (propertize (concat "[" typ "]")
384 'mouse-face 'highlight
385 'help-echo "mouse-2: restrict to this type"
388 (register-list-preserve-pos nil
390 typ register-list-current-fontification))))
391 (propertize (register-list-prepare-string
392 (register-list-value-to-string val typ) fontify)
393 'mouse-face 'highlight
394 'register-handler hdl
395 'help-echo "mouse-2: use this register")))))))
397 (goto-char (point-min))
399 (if (called-interactively-p 'interactive)
400 (message "[d]elete [e/E]dit key/value RET:jump/copy [FNRSW]:select type ?:help")
401 (message "Register type: %s" register-list-current-type)))
403 (defun register-list-call-handler-at-mouse (ev)
404 "Call the register handler at point.
405 See `register-list-call-handler-at-point' for details."
408 (register-list-call-handler-at-point))
410 (defun register-list-call-handler-at-point nil
411 "Call the register handler at point.
412 If the point is on a register key, edit the key. If the point is
413 on a register type, rebuild the list restricting to registers of
414 this type. If the point is on a register value, either jump to
415 the register or copy its value into the kill ring."
417 (let ((handler (get-text-property (point) 'register-handler)))
420 (funcall (get-text-property (point) 'register-handler))
421 (error (message "Can't jump to register location"))))))
423 (defun register-list-get-handler (register type)
424 "Return a handler function for a REGISTER with TYPE."
425 (cond ((string= "?" type)
426 `(lambda() (message "No action with this type")))
429 (kill-new ,(cdr register))
430 (message "String copied to the kill ring")))
433 (kill-new ,(number-to-string (cdr register)))
434 (message "Number copied to the kill ring as a string")))
437 (kill-new ,(mapconcat 'identity (cdr register) "\n"))
438 (message "Rectangle copied to the kill ring")))
439 ((string-match "[FMW]" type)
441 (jump-to-register ,(car register))
442 (message (format "Jumped to register %s"
443 ,(char-to-string (car register))))))))
445 (defun register-list-value-to-string (value type)
446 "Convert a register VALUE into a string according to its TYPE."
447 (cond ((string= "M" type)
448 (cond ((marker-position value)
449 (format "[Marker at point %d in buffer %s]"
450 (marker-position value)
451 (buffer-name (marker-buffer value))))
452 ((marker-buffer value)
453 (format "[Marker in buffer %s]"
454 (buffer-name (marker-buffer value))))
455 (t (format "[Marker gone?]"))))
457 (format "Number: %s" (number-to-string value)))
459 (replace-regexp-in-string "[\n\r\t]" " " value))
461 (mapconcat 'identity value "\\ "))
463 (format "[Window configuration in frame \"%s\"]"
465 (window-configuration-frame (car value)) 'name)))
467 (format "[Frame configuration]"))
468 (t "[Error: unknow type]")))
470 (defun register-list-get-type (key)
471 "Get the type for register's KEY."
473 (cond ((stringp key) "S")
477 (cond ((window-configuration-p (car key)) "W")
478 ((frame-configuration-p (car key)) "F")
479 ((stringp (car key)) "R")
480 ((string= "Unprintable entity" (car key)) "?")
483 ;;; Edit key/value of the register
486 ;; (defun register-list-edit-key-or-value nil
487 ;; "Edit the register key or value depending on the point."
489 ;; (if (get-text-property (point) 'register)
490 ;; (register-list-edit-key)
491 ;; (register-list-edit-value)))
493 (defun register-list-edit-key nil
494 "Edit the key of the register at point."
496 (register-list-set-key
497 (lambda (v) (read-char (format "New key (%s): "
498 (char-to-string v))))))
500 (defun register-list-increment-key nil
501 "Increment the key of the register at point."
503 (register-list-set-key '1+))
505 (defun register-list-delete-duplicates nil
506 "Interactively delete duplicates."
510 (if (and (eq (car r) (car rr))
512 (format "Delete register with key `%s'? "
513 (char-to-string (car rr)))))
514 (setq register-alist (delete rr register-alist))))
515 (cdr (member r register-alist))))
518 ;; (defun register-list- (register)
519 ;; "Overline the register with KEY."
521 ;; (goto-char (point-min))
522 ;; (while (re-search-forward (concat "^[ DC]" (char-to-string key)) nil t)
524 ;; (while (next-single-property-change (point) 'register)
526 (defun register-list-decrement-key nil
527 "Decrement the key of the register at point."
529 (register-list-set-key '1-))
531 (defun register-list-set-key (function)
532 "Update the regsiter key by applying FUNCTION."
533 (register-list-preserve-pos
534 2 ;; go back to top of the sorted list
536 (let* ((reg-point (next-single-property-change (point) 'register))
537 (reg (get-text-property reg-point 'register))
539 (setq register-alist (delete reg register-alist))
540 (add-to-list 'register-alist
541 (cons (setcar reg (funcall function val)) (cdr reg)))
542 (register-list register-list-current-type
543 register-list-current-fontification))))
545 (defun register-list-edit-value nil
546 "Edit the value of the register at point."
551 (next-single-property-change (point) 'register)))
552 (reg (get-text-property reg-at-point 'register))
554 (if (not (or (stringp val) (numberp val)
555 (and (listp val) (stringp (car val)))))
556 (message "Can't edit this type of register")
557 (setq register-list-temp-window-cfg (current-window-configuration))
558 (setq register-list-temp-register reg)
559 (setq register-list-temp-pos
560 (cons (line-number-at-pos (point)) (current-column)))
561 (setq register-list-edit-value-type
562 (cond ((numberp val) 'number)
563 ((listp val) 'rectangle)
565 (pop-to-buffer (get-buffer-create "*Register Edit*"))
567 (insert (cond ((numberp val) (number-to-string val))
568 ((listp val) (mapconcat 'identity val "\n"))
570 (setq register-list-rectangle-column
571 (if (eq register-list-edit-value-type 'rectangle)
572 (length (car val)) nil))
573 (register-list-edit-value-mode)
574 (message "Press C-c C-c when you're done"))))
576 (define-derived-mode register-list-edit-value-mode text-mode
577 "Edit Register Value"
578 "Mode for editing the value of a register.
579 When you are done editing the value, store it with \\[register-list-send-string].
581 \\{register-list-edit-value-mode-map}")
583 (defun register-list-add-rectangle-overlays (column)
584 "Add overlays to display strings beyond COLUMN.
585 Do this on all lines in the current buffer."
586 (register-list-map-lines
587 ((beg (progn (forward-char column) (point)))
588 (end (progn (end-of-line) (point))))
590 (overlay-put (make-overlay beg end)
591 'face 'register-list-off-rectangle))))
593 (defun register-list-add-trailing-whitespace (column)
594 "Add trailing whitespaces to fill to COLUMN.
595 Do this on all lines in the current buffer."
596 (register-list-map-lines
597 ((eol (save-excursion (end-of-line) (point)))
598 (rem (% eol (1+ column))))
599 (if (and (not (eq rem 0))
600 (< eol (* (1+ column) (line-number-at-pos (point)))))
603 (insert (make-string (- (1+ column) rem) 32))))))
605 (defun register-list-send-value nil
606 "Use the buffer to store the new value of a register.
607 Convert the buffer to a number or a rectangle if required."
610 (when register-list-rectangle-column
611 ;; fix whitespace before sending a rectangle
612 (register-list-add-trailing-whitespace
613 register-list-rectangle-column)
614 ;; cut off trailing string before sending a rectangle
615 (register-list-add-rectangle-overlays
616 register-list-rectangle-column)
617 (if (and (delq nil (overlay-lists))
618 (not (y-or-n-p "Cut off the fontified part of the rectangle? ")))
619 (throw 'cancel (message "Back to editing"))))
620 ;; now send the value
621 (set-register (car register-list-temp-register)
622 (cond ((eq register-list-edit-value-type 'number)
623 (string-to-number (buffer-string)))
624 ((eq register-list-edit-value-type 'rectangle)
625 (mapcar (lambda (l) (truncate-string-to-width
626 l register-list-rectangle-column
628 (split-string (buffer-string) "\n")))
629 (t (buffer-string))))
630 (kill-buffer (current-buffer))
631 (register-list register-list-current-type
632 register-list-current-fontification)
633 (set-window-configuration register-list-temp-window-cfg)
634 (line-move (1- (car register-list-temp-pos)) t)
635 (line-move-to-column (cdr register-list-temp-pos)))
636 ;; remove overlays if sending was cancelled
637 (mapc (lambda(ovs) (mapc (lambda(o) (delete-overlay o)) ovs))
639 (message "New value stored"))
641 (defun register-list-prepare-string (string &optional fontify)
642 "Prepare STRING for the register list.
643 An optional argument FONTIFY takes precedence over
644 `register-list-preserve-fontification' to decide whether the
645 string should keep its original fontification. Also shorten the
646 output string to `register-list-string-width'."
647 (if (and register-list-string-width
648 (> (length string) register-list-string-width))
649 (setq string (substring string 0 register-list-string-width)))
650 (when (or fontify register-list-preserve-fontification)
651 (remove-text-properties 0 (length string) '(face nil) string))
654 (provide 'register-list)
656 ;;; register-list.el ends here