code.delx.au - gnu-emacs-elpa/blob - packages/register-list/register-list.el

   1 ;;; register-list.el ---  Interactively list/edit registers
   2 ;;
   3 ;; Copyright (C) 2011  Free Software Foundation, Inc.
   4 ;;
   5 ;; Filename: register-list.el
   6 ;; Author: Bastien Guerry <bzg AT altern DOT org>
   7 ;; Maintainer: Bastien Guerry <bzg AT altern DOT org>
   8 ;; Keywords: register
   9 ;; Description: List and edit the register
  10 ;; Version: 0.1
  11 ;;
  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)
  15 ;; any later version.
  16 ;;
  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.
  21 ;;
  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.
  25 ;;
  26 ;; This is not part of GNU Emacs.
  27 ;;
  28 ;;; Commentary:
  29 ;;
  30 ;; This library lets you list and edit registers.  M-x `register-list'
  31 ;; displays a list of currently set registers.
  32
  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
  36 ;; process with `x'.
  37
  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.
  42 ;;
  43 ;; Put this file into your load-path and the following into your ~/.emacs:
  44 ;;   (require 'register-list)
  45 ;;
  46 ;;; Todo:
  47 ;;
  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
  55 ;;
  56 ;;; History:
  57 ;;
  58 ;; - [2008-03-09] Released v0.1
  59 ;;   http://article.gmane.org/gmane.emacs.sources/2832
  60 ;;
  61 ;;; Code:
  62
  63 (eval-when-compile
  64   (require 'cl))
  65
  66 (defgroup register-list nil
  67   "Interactively list/edit registers."
  68   :tag "Register List"
  69   :group 'register)
  70
  71 (defcustom register-list-string-width nil
  72   "Maximum width for the register value string."
  73   :type 'integer
  74   :group 'register-list)
  75
  76 (defcustom register-list-preserve-fontification nil
  77   "Non-nil means keep the value strings fontified."
  78   :type 'integer
  79   :group 'register-list)
  80
  81 (defcustom register-list-default-types "[FNMRSW]"
  82   "A regexp matching the default register types to list.
  83
  84 The available types are: [F]rame [N]umber [M]arkers [R]ectangle
  85 \[S]string and [W]window.  [FW] will list markers, frame and
  86 window configuration, [SM] will list strings and markers, etc."
  87   :type 'regexp
  88   :group 'register-list)
  89
  90 (defface register-list-off-rectangle
  91   '((t (:inverse-video t)))
  92   "Face used to show what falls out of a rectangle."
  93   :group 'register-list)
  94
  95 ;;; Variables, map, mode
  96
  97 (defvar register-list-mode-map nil
  98   "Keymap for `register-list-mode'.")
  99 (defvar register-list-edit-value-mode-map (copy-keymap text-mode-map)
 100   "Keymap for editing the value of a register.")
 101 (defvar register-list-current-type nil
 102   "The current type for the register menu.")
 103 (defvar register-list-current-fontification nil
 104   "Whether the value strings are currently fontified.")
 105 (defvar register-list-temp-pos nil
 106   "Temporary store the line the cursor is on.")
 107 (defvar register-list-temp-window-cfg nil
 108   "Temporary window configuration.
 109 Saved before editing the value of a register.")
 110 (defvar register-list-temp-register nil
 111   "Temporary value of the edited register.")
 112 (defvar register-list-edit-value-type nil
 113   "The type of the edited value.")
 114 (defvar register-list-rectangle-column nil
 115   "End of a rectangle line.")
 116
 117 (if register-list-mode-map
 118   nil
 119   (setq register-list-mode-map (make-keymap))
 120   (suppress-keymap register-list-mode-map t)
 121   (define-key register-list-mode-map "q" 'quit-window)
 122   (define-key register-list-mode-map "Q" 'register-list-quit)
 123   (define-key register-list-mode-map [(tab)] 'register-list-tab)
 124   (define-key register-list-mode-map "d" 'register-list-mark-delete)
 125   (define-key register-list-mode-map "D" 'register-list-delete-duplicates)
 126   (define-key register-list-mode-map "c" 'register-list-mark-concat)
 127   (define-key register-list-mode-map "x" 'register-list-execute)
 128   (define-key register-list-mode-map "+" 'register-list-increment-key)
 129   (define-key register-list-mode-map "-" 'register-list-decrement-key)
 130   (define-key register-list-mode-map "e" 'register-list-edit-key)
 131   (define-key register-list-mode-map "E" 'register-list-edit-value)
 132   (define-key register-list-mode-map "f" 'register-list-toggle-fontification)
 133   (define-key register-list-mode-map " " 'next-line)
 134   (define-key register-list-mode-map "n" 'next-line)
 135   (define-key register-list-mode-map "p" 'previous-line)
 136   (define-key register-list-mode-map "u" 'register-list-unmark)
 137   (define-key register-list-mode-map "U" 'register-list-unmark-all)
 138   (define-key register-list-mode-map "g" 'register-list-refresh)
 139   (define-key register-list-mode-map "F"
 140     (lambda () (interactive) (register-list-refresh "F")))
 141   (define-key register-list-mode-map "N"
 142     (lambda () (interactive) (register-list-refresh "N")))
 143   (define-key register-list-mode-map "M"
 144     (lambda () (interactive) (register-list-refresh "M")))
 145   (define-key register-list-mode-map "R"
 146     (lambda () (interactive) (register-list-refresh "R")))
 147   (define-key register-list-mode-map "S"
 148     (lambda () (interactive) (register-list-refresh "S")))
 149   (define-key register-list-mode-map "W"
 150     (lambda () (interactive) (register-list-refresh "W")))
 151   (define-key register-list-mode-map "G"
 152     (lambda() (interactive) (register-list-refresh "[FNMRSW]")))
 153   (define-key register-list-mode-map "?" 'describe-mode))
 154
 155 (define-key register-list-mode-map [follow-link] 'mouse-face)
 156 (define-key register-list-mode-map [mouse-2] 'register-list-call-handler-at-mouse)
 157 (define-key register-list-mode-map [(return)] 'register-list-call-handler-at-point)
 158 (define-key register-list-edit-value-mode-map (kbd "C-c C-c")
 159   'register-list-send-value)
 160
 161 ;;; Marks
 162
 163 (defmacro register-list-preserve-pos (force-line &rest body)
 164   "Preserve the position and execute BODY.
 165 If FORCE-LINE is non-nil, force moving to this line."
 166   `(let ((line (line-number-at-pos (point)))
 167          (col (current-column)))
 168      ,@body
 169      (goto-char (point-min))
 170      (line-move ,(or (eval force-line) '(1- line)) t)
 171      (line-move-to-column col)))
 172
 173 (defmacro register-list-map-lines (let-vals &rest body)
 174   "Execute BODY inside a let form with LET-VALS on all lines."
 175   `(save-excursion
 176      (goto-char (point-min))
 177      (while (not (eobp))
 178        (let* ,let-vals
 179          ,@body
 180          (forward-line 1)))))
 181
 182 (defvar register-list-concat-separator "\n"
 183   "Default separator when merging.")
 184
 185 (defvar register-list-concat-key-select 'last)
 186
 187 ;; FIXME skip rectangle (or handle them separatly
 188 (defun register-list-execute nil
 189   "Delete/concatenate registers marker for deletion/concatenation."
 190   (interactive)
 191   (let ((line (line-number-at-pos (point))) newreg concat)
 192     (goto-char (point-min))
 193     (while (re-search-forward "^[DC]" nil t)
 194       (let* ((reg-point (next-single-property-change (point) 'register))
 195              (reg (get-text-property reg-point 'register)))
 196         (if (string= (match-string 0) "D")
 197             (setq register-alist (delete reg register-alist))
 198           (push reg concat))))
 199     (when concat
 200       ;; set the new register
 201       (setq newreg
 202             (cons (cond ((eq register-list-concat-key-select 'first)
 203                          (caar concat))
 204                         ((eq register-list-concat-key-select 'last)
 205                          (caar (reverse concat)))
 206                         (t (read-char
 207                             (format "Key [%s]: "
 208                                     (mapconcat (lambda(x) (char-to-string (car x)))
 209                                                concat "")))))
 210                   (mapconcat (lambda (i) (cdr i)) (reverse concat)
 211                              (cond ((eq register-list-concat-separator 'ask)
 212                                     (read-from-minibuffer "Separator: "))
 213                                    ((stringp register-list-concat-separator)
 214                                     register-list-concat-separator)
 215                                    (t "")))))
 216       ;; delete old registers
 217       (dolist (r concat)
 218         (setq register-alist (delete r register-alist)))
 219       ;; push the new register
 220       (push newreg register-alist))
 221     (register-list register-list-current-type
 222                    register-list-current-fontification)
 223     ;; move the cursor back
 224     (goto-char (point-min))
 225     (line-move (- line 2) t)))
 226
 227 (defun register-list-set-mark (mark)
 228   "Set mark at the beginning of the line."
 229   (let ((inhibit-read-only t))
 230     (beginning-of-line)
 231     (unless (get-text-property (point) 'intangible)
 232       (delete-char 1)
 233       (save-excursion (insert mark))
 234       (unless (save-excursion (forward-line 1) (eobp))
 235         (forward-line 1)))))
 236
 237 (defun register-list-mark-delete nil
 238   "Mark the register at point for deletion."
 239   (interactive)
 240   (register-list-set-mark "D"))
 241
 242 (defun register-list-mark-concat nil
 243   "Mark the register at point for further concatenation."
 244   (interactive)
 245   (register-list-set-mark "C"))
 246
 247 (defun register-list-unmark nil
 248   "Unmark the register at point."
 249   (interactive)
 250   (register-list-set-mark " "))
 251
 252 (defun register-list-unmark-all nil
 253   "Unmark all registers."
 254   (interactive)
 255   (let ((inhibit-read-only t))
 256     (save-excursion
 257       (goto-char (point-min))
 258       (forward-line 1)
 259       (while (and (forward-line 1) (not (eobp)))
 260         (delete-char 1)
 261         (insert " ")))))
 262
 263 (defun register-list-refresh (&optional type)
 264   "Refresh the list of registers.
 265 An optional TYPE argument restrict the list these types."
 266   (interactive "P")
 267   (register-list-preserve-pos
 268    (1- (line-number-at-pos (point)))
 269    (register-list (or type register-list-current-type)
 270                   register-list-current-fontification)))
 271
 272 (defun register-list-quit nil
 273   "Quit the register list and kill its buffer."
 274   (interactive)
 275   (kill-buffer (current-buffer)))
 276
 277 (defun register-list-toggle-fontification nil
 278   "Toggle fontification of the value strings."
 279   (interactive)
 280   (register-list-preserve-pos
 281    nil
 282    (setq register-list-current-fontification
 283          (not register-list-current-fontification))
 284    (register-list register-list-current-type
 285                   register-list-current-fontification)))
 286
 287 (defun register-list-mode ()
 288   "Major mode for editing a list of register keys.
 289
 290 Each line is of the form:
 291
 292 \[Delete-flag] Key Type Value
 293
 294 The leftmost column displays a `D' character if the register key
 295 is flagged for further deletion.  You can add such flag by hitting
 296 \\[register-list-delete].
 297
 298 The Key column displays the character used for this register.
 299 Hitting \\[register-list-call-handler-at-point] on the key will
 300 prompt for a replacement.
 301
 302 The Type column displays the type of the register, either [F]rame
 303 \[N]umber [M]arkers [R]ectangle [S]string or [W]window.  Hitting
 304 \\[register-list-call-handler-at-point] on this column will
 305 restrict the register list to this type of registers.  To quickly
 306 list a specific type, hit the type character among [FNMRSW].
 307
 308 The Value column displays information about the value of the
 309 register: either a string if the register's value is a string, a
 310 number or a rectangle, or the location of the marker or some
 311 information about window and frame configuration.  Hitting
 312 \\[register-list-call-handler-at-point] on this column will
 313 copy the string to the kill ring or jump to the location.
 314
 315 \\[register-list-edit-key] -- edit the key for this register.
 316 \\[register-list-edit-value] -- edit the value for this register.
 317 \\[register-list-increment-key] -- increment key at point.
 318 \\[register-list-decrement-key] -- decrement key at point.
 319 \\[register-list-mark-delete] -- mark the register at point for deletion.
 320 \\[register-list-mark-concat] -- mark the register at point for concatenation.
 321 \\[register-list-unmark] -- unmark the register at point.
 322 \\[register-list-unmark-all] -- unmark all registers.
 323 \\[register-list-execute] -- execute deletions or concatenations.
 324 \\[register-list-toggle-fontification] -- toggle fontification of value strings.
 325 \\[register-list-refresh] -- refresh the register menu display.
 326 \\[register-list-tab] -- cycle between the key, the type and the value.
 327 \\[register-list-quit] -- quit the register menu."
 328   (kill-all-local-variables)
 329   (use-local-map register-list-mode-map)
 330   (setq truncate-lines t)
 331   (setq buffer-read-only t)
 332   (setq major-mode 'register-list-mode)
 333   (setq mode-name "Register List"))
 334
 335 ;;\\[register-list-edit-key-or-value] -- edit the key for this register.
 336
 337 (defun register-list-tab nil
 338   "Cycle between the register key, the type and the value."
 339   (interactive)
 340   (let* ((eol (save-excursion (end-of-line) (point)))
 341          (m-f-chg (next-single-property-change (point) 'mouse-face nil eol))
 342          (m-f-pos (text-property-any m-f-chg eol 'mouse-face 'highlight))
 343          (r-f-chg (next-single-property-change (point) 'register nil eol))
 344          (r-f-prop (get-text-property r-f-chg 'register)) point)
 345     (cond (r-f-prop (goto-char r-f-chg))
 346           (m-f-pos (goto-char m-f-pos))
 347           (t  (beginning-of-line 2)
 348               (if (setq point (next-single-property-change
 349                                (point) 'register))
 350                   (goto-char point))))))
 351
 352 ;;;###autoload
 353 (defun register-list (&optional type fontify)
 354   "Display a list of registers.
 355 An optional argument TYPE defines a regexp to restrict the
 356 register menu to.  A second optional argument FONTIFICATION
 357 decides if the display preserves original fontification for
 358 values.
 359
 360 The default types are defined in `register-list-default-types',
 361 which see.
 362
 363 The list is displayed in a buffer named `*Register List*' in
 364 `register-list-mode', which see."
 365   (interactive)
 366   (switch-to-buffer (get-buffer-create "*Register List*"))
 367   (let ((inhibit-read-only t) reg-alist)
 368     (setq type (or type register-list-default-types))
 369     (setq register-list-current-fontification
 370           (or fontify register-list-preserve-fontification))
 371     (setq register-list-current-type type)
 372
 373     (setq register-alist ;; TODO better sorting
 374           (sort register-alist (lambda (a b) (< (car a) (car b)))))
 375     (erase-buffer)
 376     (insert (concat (propertize "% Key  Type  Value\n"
 377                                 'face 'font-lock-type-face
 378                                 'intangible t) ;; 'front-sticky t)
 379                     (propertize "- ---  ----  -----\n"
 380                                 'intangible t
 381                                 'face 'font-lock-comment-delimiter-face)))
 382     (mapc
 383      (lambda (register)
 384        (let* ((key (char-to-string (car register)))
 385               (val (cdr register))
 386               (typ (register-list-get-type val))
 387               (hdl (register-list-get-handler register typ)))
 388          (when (string-match typ type)
 389            (insert
 390             (format "  %s    %s   %s\n"
 391                     (propertize key 'face 'bold 'register register
 392                                 'register-handler hdl)
 393                     (propertize (concat "[" typ "]")
 394                                 'mouse-face 'highlight
 395                                 'help-echo "mouse-2: restrict to this type"
 396                                 'register-handler
 397                                 `(lambda()
 398                                    (register-list-preserve-pos nil
 399                                     (register-list
 400                                      ,typ ,register-list-current-fontification))))
 401                     (propertize (register-list-prepare-string
 402                                  (register-list-value-to-string val typ) fontify)
 403                                 'mouse-face 'highlight
 404                                 'register-handler hdl
 405                                 'help-echo "mouse-2: use this register"))))))
 406      register-alist))
 407   (register-list-mode)
 408   (goto-char (point-min))
 409   (line-move 2 t)
 410   (if (called-interactively-p)
 411       (message "[d]elete  [e/E]dit key/value  RET:jump/copy  [FNRSW]:select type  ?:help")
 412     (message "Register type: %s" register-list-current-type)))
 413
 414 (defun register-list-call-handler-at-mouse (ev)
 415   "Call the register handler at point.
 416 See `register-list-call-handler-at-point' for details."
 417   (interactive "e")
 418   (mouse-set-point ev)
 419   (register-list-call-handler-at-point))
 420
 421 (defun register-list-call-handler-at-point nil
 422   "Call the register handler at point.
 423 If the point is on a register key, edit the key.  If the point is
 424 on a register type, rebuild the list restricting to registers of
 425 this type.  If the point is on a register value, either jump to
 426 the register or copy its value into the kill ring."
 427   (interactive)
 428   (let ((handler (get-text-property (point) 'register-handler)))
 429     (if handler
 430         (condition-case nil
 431             (funcall (get-text-property (point) 'register-handler))
 432           (error (message "Can't jump to register location"))))))
 433
 434 (defun register-list-get-handler (register type)
 435   "Return a handler function for a REGISTER with TYPE."
 436   (cond ((string= "?" type)
 437          `(lambda() (message "No action with this type")))
 438         ((string= "S" type)
 439          `(lambda()
 440             (kill-new ,(cdr register))
 441             (message "String copied to the kill ring")))
 442         ((string= "N" type)
 443          `(lambda()
 444             (kill-new ,(number-to-string (cdr register)))
 445             (message "Number copied to the kill ring as a string")))
 446         ((string= "R" type)
 447          `(lambda()
 448             (kill-new ,(mapconcat 'identity (cdr register) "\n"))
 449             (message "Rectangle copied to the kill ring")))
 450         ((string-match "[FMW]" type)
 451          `(lambda()
 452             (jump-to-register ,(car register))
 453             (message (format "Jumped to register %s"
 454                              ,(char-to-string (car register))))))))
 455
 456 (defun register-list-value-to-string (value type)
 457   "Convert a register VALUE into a string according to its TYPE."
 458   (cond ((string= "M" type)
 459          (cond ((marker-position value)
 460                 (format "[Marker at point %d in buffer %s]"
 461                         (marker-position value)
 462                         (buffer-name (marker-buffer value))))
 463                ((marker-buffer value)
 464                 (format "[Marker in buffer %s]"
 465                         (buffer-name (marker-buffer value))))
 466                (t (format "[Marker gone?]"))))
 467         ((string= "N" type)
 468          (format "Number: %s" (number-to-string value)))
 469         ((string= "S" type)
 470          (replace-regexp-in-string "[\n\r\t]" " " value))
 471         ((string= "R" type)
 472          (mapconcat 'identity value "\\ "))
 473         ((string= "W" type)
 474          (format "[Window configuration in frame \"%s\"]"
 475                   (frame-parameter
 476                    (window-configuration-frame (car value)) 'name)))
 477         ((string= "F" type)
 478          (format "[Frame configuration]"))
 479         (t "[Error: unknow type]")))
 480
 481 (defun register-list-get-type (key)
 482   "Get the type for register's KEY."
 483   (if (atom key)
 484       (cond ((stringp key) "S")
 485             ((markerp key) "M")
 486             ((numberp key) "N")
 487             (t "error"))
 488     (cond ((window-configuration-p (car key)) "W")
 489           ((frame-configuration-p (car key)) "F")
 490           ((stringp (car key)) "R")
 491           ((string= "Unprintable entity" (car key)) "?")
 492           (t "error"))))
 493
 494 ;;; Edit key/value of the register
 495
 496 ;; FIXME delete?
 497 ;; (defun register-list-edit-key-or-value nil
 498 ;;   "Edit the register key or value depending on the point."
 499 ;;   (interactive)
 500 ;;   (if (get-text-property (point) 'register)
 501 ;;       (register-list-edit-key)
 502 ;;     (register-list-edit-value)))
 503
 504 (defun register-list-edit-key nil
 505   "Edit the key of the register at point."
 506   (interactive)
 507   (register-list-set-key
 508    (lambda (v) (read-char (format "New key (%s): "
 509                                   (char-to-string v))))))
 510
 511 (defun register-list-increment-key nil
 512   "Increment the key of the register at point."
 513   (interactive)
 514   (register-list-set-key '1+))
 515
 516 (defun register-list-delete-duplicates nil
 517   "Interactively delete duplicates."
 518   (interactive)
 519   (mapc (lambda (r)
 520           (mapc (lambda(rr)
 521                   (if (and (eq (car r) (car rr))
 522                            (y-or-n-p
 523                             (format "Delete register with key `%s'? "
 524                                     (char-to-string (car rr)))))
 525                       (setq register-alist (delete rr register-alist))))
 526                 (cdr (member r register-alist))))
 527         register-alist))
 528
 529 ;; (defun register-list- (register)
 530 ;;   "Overline the register with KEY."
 531 ;;   (save-excursion
 532 ;;     (goto-char (point-min))
 533 ;;     (while (re-search-forward (concat "^[ DC]" (char-to-string key)) nil t)
 534 ;;       (goto-char
 535 ;;     (while (next-single-property-change (point) 'register)
 536
 537 (defun register-list-decrement-key nil
 538   "Decrement the key of the register at point."
 539   (interactive)
 540   (register-list-set-key '1-))
 541
 542 (defun register-list-set-key (function)
 543   "Update the regsiter key by applying FUNCTION."
 544   (register-list-preserve-pos
 545    2 ;; go back to top of the sorted list
 546    (beginning-of-line)
 547    (let* ((reg-point (next-single-property-change (point) 'register))
 548           (reg (get-text-property reg-point 'register))
 549           (val (car reg)))
 550      (setq register-alist (delete reg register-alist))
 551      (add-to-list 'register-alist
 552                   (cons (setcar reg (funcall function val)) (cdr reg)))
 553      (register-list register-list-current-type
 554                     register-list-current-fontification))))
 555
 556 (defun register-list-edit-value nil
 557   "Edit the value of the register at point."
 558   (interactive)
 559   (let* ((reg-at-point
 560           (save-excursion
 561             (beginning-of-line)
 562             (next-single-property-change (point) 'register)))
 563          (reg (get-text-property reg-at-point 'register))
 564          (val (cdr reg))
 565          new-val)
 566     (if (not (or (stringp val) (numberp val)
 567                  (and (listp val) (stringp (car val)))))
 568         (message "Can't edit this type of register")
 569       (setq register-list-temp-window-cfg (current-window-configuration))
 570       (setq register-list-temp-register reg)
 571       (setq register-list-temp-pos
 572             (cons (line-number-at-pos (point)) (current-column)))
 573       (setq register-list-edit-value-type
 574             (cond ((numberp val) 'number)
 575                   ((listp val) 'rectangle)
 576                   (t 'string)))
 577       (pop-to-buffer (get-buffer-create "*Register Edit*"))
 578       (erase-buffer)
 579       (insert (cond ((numberp val) (number-to-string val))
 580                     ((listp val) (mapconcat 'identity val "\n"))
 581                     (t val)))
 582       (setq register-list-rectangle-column
 583             (if (eq register-list-edit-value-type 'rectangle)
 584                 (length (car val)) nil))
 585       (register-list-edit-value-mode)
 586       (message "Press C-c C-c when you're done"))))
 587
 588 (defun register-list-edit-value-mode nil
 589   "Mode for editing the value of a register.
 590 When you are done editing the value, store it with \\[register-list-send-string].
 591
 592 \\{register-list-edit-value-mode-map}"
 593   (interactive)
 594   (kill-all-local-variables)
 595   (use-local-map register-list-edit-value-mode-map)
 596   (setq major-mode 'register-list-edit-value-mode
 597         mode-name "Edit Register Value")
 598   (run-mode-hooks 'text-mode-hook))
 599
 600 (defun register-list-add-rectangle-overlays (column)
 601   "Add overlays to display strings beyond COLUMN.
 602 Do this on all lines in the current buffer."
 603   (register-list-map-lines
 604    ((beg (progn (forward-char column) (point)))
 605     (end (progn (end-of-line) (point))))
 606    (unless (eq beg end)
 607      (overlay-put (make-overlay beg end)
 608                   'face 'register-list-off-rectangle))))
 609
 610 (defun register-list-add-trailing-whitespace (column)
 611   "Add trailing whitespaces to fill to COLUMN.
 612 Do this on all lines in the current buffer."
 613   (register-list-map-lines
 614    ((eol (save-excursion (end-of-line) (point)))
 615     (rem (% eol (1+ column))))
 616    (if (and (not (eq rem 0))
 617             (< eol (* (1+ column) (line-number-at-pos (point)))))
 618        (save-excursion
 619          (end-of-line)
 620          (insert (make-string (- (1+ column) rem) 32))))))
 621
 622 (defun register-list-send-value nil
 623   "Use the buffer to store the new value of a register.
 624 Convert the buffer to a number or a rectangle if required."
 625   (interactive)
 626   (catch 'cancel
 627     (when register-list-rectangle-column
 628       ;; fix whitespace before sending a rectangle
 629       (register-list-add-trailing-whitespace
 630        register-list-rectangle-column)
 631       ;; cut off trailing string before sending a rectangle
 632       (register-list-add-rectangle-overlays
 633        register-list-rectangle-column)
 634       (if (and (delq nil (overlay-lists))
 635                (not (y-or-n-p "Cut off the fontified part of the rectangle? ")))
 636           (throw 'cancel (message "Back to editing"))))
 637     ;; now send the value
 638     (set-register (car register-list-temp-register)
 639                   (cond ((eq register-list-edit-value-type 'number)
 640                          (string-to-number (buffer-string)))
 641                         ((eq register-list-edit-value-type 'rectangle)
 642                          (mapcar (lambda (l) (truncate-string-to-width
 643                                               l register-list-rectangle-column
 644                                               0 32))
 645                                  (split-string (buffer-string) "\n")))
 646                         (t (buffer-string))))
 647     (kill-buffer (current-buffer))
 648     (register-list register-list-current-type
 649                    register-list-current-fontification)
 650     (set-window-configuration register-list-temp-window-cfg)
 651     (line-move (1- (car register-list-temp-pos)) t)
 652     (line-move-to-column (cdr register-list-temp-pos)))
 653   ;; remove overlays if sending was cancelled
 654   (mapc (lambda(ovs) (mapc (lambda(o) (delete-overlay o)) ovs))
 655         (overlay-lists))
 656   (message "New value stored"))
 657
 658 (defun register-list-prepare-string (string &optional fontify)
 659   "Prepare STRING for the register list.
 660 An optional argument FONTIFY takes precedence over
 661 `register-list-preserve-fontification' to decide whether the
 662 string should keep its original fontification.  Also shorten the
 663 output string to `register-list-string-width'."
 664   (if (and register-list-string-width
 665            (> (length string) register-list-string-width))
 666       (setq string (substring string 0 register-list-string-width)))
 667   (when (or fontify register-list-preserve-fontification)
 668     (remove-text-properties 0 (length string) '(face nil) string))
 669   string)
 670
 671 (provide 'register-list)
 672
 673 ;;; register-list.el ends here