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

   1 ;;; register-list.el ---  Interactively list/edit registers  -*- lexical-binding:t -*-
   2 ;;
   3 ;; Copyright (C) 2011-2015  Free Software Foundation, Inc.
   4 ;;
   5 ;; Filename: register-list.el
   6 ;; Author: Bastien Guerry <bzg@gnu.org>
   7 ;; Maintainer: Bastien Guerry <bzg@gnu.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
  75 (defcustom register-list-preserve-fontification nil
  76   "Non-nil means keep the value strings fontified."
  77   :type 'integer)
  78
  79 (defcustom register-list-default-types "[FNMRSW]"
  80   "A regexp matching the default register types to list.
  81
  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."
  85   :type 'regexp)
  86
  87 (defface register-list-off-rectangle
  88   '((t (:inverse-video t)))
  89   "Face used to show what falls out of a rectangle.")
  90
  91 ;;; Variables, map, mode
  92
  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)
 114     (define-key map "F"
 115       (lambda () (interactive) (register-list-refresh "F")))
 116     (define-key map "N"
 117       (lambda () (interactive) (register-list-refresh "N")))
 118     (define-key map "M"
 119       (lambda () (interactive) (register-list-refresh "M")))
 120     (define-key map "R"
 121       (lambda () (interactive) (register-list-refresh "R")))
 122     (define-key map "S"
 123       (lambda () (interactive) (register-list-refresh "S")))
 124     (define-key map "W"
 125       (lambda () (interactive) (register-list-refresh "W")))
 126     (define-key map "G"
 127       (lambda() (interactive) (register-list-refresh "[FNMRSW]")))
 128     (define-key map "?" 'describe-mode)
 129
 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)
 133     map)
 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)
 138     map)
 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.")
 155
 156 ;;; Marks
 157
 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)))
 164      ,@body
 165      (goto-char (point-min))
 166      (forward-line ,(or force-line '(1- line)))
 167      (line-move-to-column col)))
 168
 169 (defmacro register-list-map-lines (let-vals &rest body)
 170   "Execute BODY inside a let form with LET-VALS on all lines."
 171   `(save-excursion
 172      (goto-char (point-min))
 173      (while (not (eobp))
 174        (let* ,let-vals
 175          ,@body
 176          (forward-line 1)))))
 177
 178 (defvar register-list-concat-separator "\n"
 179   "Default separator when merging.")
 180
 181 (defvar register-list-concat-key-select 'last)
 182
 183 ;; FIXME skip rectangle (or handle them separatly
 184 (defun register-list-execute nil
 185   "Delete/concatenate registers marker for deletion/concatenation."
 186   (interactive)
 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))
 194           (push reg concat))))
 195     (when concat
 196       ;; set the new register
 197       (setq newreg
 198             (cons (cond ((eq register-list-concat-key-select 'first)
 199                          (caar concat))
 200                         ((eq register-list-concat-key-select 'last)
 201                          (caar (reverse concat)))
 202                         (t (read-char
 203                             (format "Key [%s]: "
 204                                     (mapconcat (lambda(x) (char-to-string (car x)))
 205                                                concat "")))))
 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)
 211                                    (t "")))))
 212       ;; delete old registers
 213       (dolist (r concat)
 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)))
 222
 223 (defconst register-list--intangible
 224   (if (fboundp 'cursor-intangible-mode)
 225       'cursor-intangible 'intangible))
 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) register-list--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 nil
 268     (register-list (or type register-list-current-type)
 269                    register-list-current-fontification)))
 270
 271 (defun register-list-quit nil
 272   "Quit the register list and kill its buffer."
 273   (interactive)
 274   (kill-buffer (current-buffer)))
 275
 276 (defun register-list-toggle-fontification nil
 277   "Toggle fontification of the value strings."
 278   (interactive)
 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)))
 284
 285 (define-derived-mode register-list-mode special-mode "Register List"
 286   "Major mode for editing a list of register keys.
 287
 288 Each line is of the form:
 289
 290 \[Delete-flag] Key Type Value
 291
 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].
 295
 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.
 299
 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].
 305
 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.
 312
 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))
 329
 330 ;;\\[register-list-edit-key-or-value] -- edit the key for this register.
 331
 332 (defun register-list-tab nil
 333   "Cycle between the register key, the type and the value."
 334   (interactive)
 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
 344                                (point) 'register))
 345                   (goto-char point))))))
 346
 347 ;;;###autoload
 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
 353 values.
 354
 355 The default types are defined in `register-list-default-types',
 356 which see.
 357
 358 The list is displayed in a buffer named `*Register List*' in
 359 `register-list-mode', which see."
 360   (interactive)
 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)
 367
 368     (setq register-alist ;; TODO better sorting.
 369           (sort register-alist (lambda (a b) (< (car a) (car b)))))
 370     (erase-buffer)
 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)))
 380              (val (cdr register))
 381              (typ (register-list-get-type val))
 382              (hdl (register-list-get-handler register typ)))
 383         (when (string-match typ type)
 384           (insert
 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"
 391                                'register-handler
 392                                (lambda ()
 393                                  (register-list-preserve-pos nil
 394                                    (register-list
 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")))))))
 401   (register-list-mode)
 402   (goto-char (point-min))
 403   (line-move 2 t)
 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)))
 407
 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."
 411   (interactive "e")
 412   (mouse-set-point ev)
 413   (register-list-call-handler-at-point))
 414
 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."
 421   (interactive)
 422   (let ((handler (get-text-property (point) 'register-handler)))
 423     (if handler
 424         (condition-case nil
 425             (funcall (get-text-property (point) 'register-handler))
 426           (error (message "Can't jump to register location"))))))
 427
 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")))
 432         ((string= "S" type)
 433          `(lambda()
 434             (kill-new ,(cdr register))
 435             (message "String copied to the kill ring")))
 436         ((string= "N" type)
 437          `(lambda()
 438             (kill-new ,(number-to-string (cdr register)))
 439             (message "Number copied to the kill ring as a string")))
 440         ((string= "R" type)
 441          `(lambda()
 442             (kill-new ,(mapconcat 'identity (cdr register) "\n"))
 443             (message "Rectangle copied to the kill ring")))
 444         ((string-match "[FMW]" type)
 445          `(lambda()
 446             (jump-to-register ,(car register))
 447             (message (format "Jumped to register %s"
 448                              ,(char-to-string (car register))))))))
 449
 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?]"))))
 461         ((string= "N" type)
 462          (format "Number: %s" (number-to-string value)))
 463         ((string= "S" type)
 464          (replace-regexp-in-string "[\n\r\t]" " " value))
 465         ((string= "R" type)
 466          (mapconcat 'identity value "\\ "))
 467         ((string= "W" type)
 468          (format "[Window configuration in frame \"%s\"]"
 469                   (frame-parameter
 470                    (window-configuration-frame (car value)) 'name)))
 471         ((string= "F" type)
 472          (format "[Frame configuration]"))
 473         (t "[Error: unknow type]")))
 474
 475 (defun register-list-get-type (key)
 476   "Get the type for register's KEY."
 477   (if (atom key)
 478       (cond ((stringp key) "S")
 479             ((markerp key) "M")
 480             ((numberp key) "N")
 481             (t "error"))
 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)) "?")
 486           (t "error"))))
 487
 488 ;;; Edit key/value of the register
 489
 490 ;; FIXME delete?
 491 ;; (defun register-list-edit-key-or-value nil
 492 ;;   "Edit the register key or value depending on the point."
 493 ;;   (interactive)
 494 ;;   (if (get-text-property (point) 'register)
 495 ;;       (register-list-edit-key)
 496 ;;     (register-list-edit-value)))
 497
 498 (defun register-list-edit-key nil
 499   "Edit the key of the register at point."
 500   (interactive)
 501   (register-list-set-key
 502    (lambda (v) (read-char (format "New key (%s): "
 503                                   (char-to-string v))))))
 504
 505 (defun register-list-increment-key nil
 506   "Increment the key of the register at point."
 507   (interactive)
 508   (register-list-set-key '1+))
 509
 510 (defun register-list-delete-duplicates nil
 511   "Interactively delete duplicates."
 512   (interactive)
 513   (mapc (lambda (r)
 514           (mapc (lambda(rr)
 515                   (if (and (eq (car r) (car rr))
 516                            (y-or-n-p
 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))))
 521         register-alist))
 522
 523 ;; (defun register-list- (register)
 524 ;;   "Overline the register with KEY."
 525 ;;   (save-excursion
 526 ;;     (goto-char (point-min))
 527 ;;     (while (re-search-forward (concat "^[ DC]" (char-to-string key)) nil t)
 528 ;;       (goto-char
 529 ;;     (while (next-single-property-change (point) 'register)
 530
 531 (defun register-list-decrement-key nil
 532   "Decrement the key of the register at point."
 533   (interactive)
 534   (register-list-set-key '1-))
 535
 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
 540     (beginning-of-line)
 541     (let* ((reg-point (next-single-property-change (point) 'register))
 542            (reg (get-text-property reg-point 'register))
 543            (val (car reg)))
 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))))
 549
 550 (defun register-list-edit-value nil
 551   "Edit the value of the register at point."
 552   (interactive)
 553   (let* ((reg-at-point
 554           (save-excursion
 555             (beginning-of-line)
 556             (next-single-property-change (point) 'register)))
 557          (reg (get-text-property reg-at-point 'register))
 558          (val (cdr reg)))
 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)
 569                   (t 'string)))
 570       (pop-to-buffer (get-buffer-create "*Register Edit*"))
 571       (erase-buffer)
 572       (insert (cond ((numberp val) (number-to-string val))
 573                     ((listp val) (mapconcat 'identity val "\n"))
 574                     (t val)))
 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"))))
 580
 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].
 585
 586 \\{register-list-edit-value-mode-map}")
 587
 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))))
 594    (unless (eq beg end)
 595      (overlay-put (make-overlay beg end)
 596                   'face 'register-list-off-rectangle))))
 597
 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)))))
 606        (save-excursion
 607          (end-of-line)
 608          (insert (make-string (- (1+ column) rem) 32))))))
 609
 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."
 613   (interactive)
 614   (catch 'cancel
 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
 632                                               0 32))
 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))
 643         (overlay-lists))
 644   (message "New value stored"))
 645
 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))
 657   string)
 658
 659 (provide 'register-list)
 660
 661 ;;; register-list.el ends here