rect.el 21.3 KB
Newer Older
1
;;; rect.el --- rectangle functions for GNU Emacs  -*- lexical-binding:t -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

3
;; Copyright (C) 1985, 1999-2013 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

5
;; Maintainer: Didier Verna <didier@xemacs.org>
Eric S. Raymond's avatar
Eric S. Raymond committed
6
;; Keywords: internal
7
;; Package: emacs
Eric S. Raymond's avatar
Eric S. Raymond committed
8

Joseph Arceneaux's avatar
Joseph Arceneaux committed
9 10
;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Joseph Arceneaux's avatar
Joseph Arceneaux committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
15 16 17 18 19 20 21

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
22
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
23

24 25
;;; Commentary:

26
;; This package provides the operations on rectangles that are documented
27 28
;; in the Emacs manual.

29 30
;; ### NOTE: this file was almost completely rewritten by Didier Verna
;; <didier@xemacs.org> in July 1999.
31

Eric S. Raymond's avatar
Eric S. Raymond committed
32
;;; Code:
Joseph Arceneaux's avatar
Joseph Arceneaux committed
33

34
;; FIXME: this function should be replaced by `apply-on-rectangle'
Joseph Arceneaux's avatar
Joseph Arceneaux committed
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
(defun operate-on-rectangle (function start end coerce-tabs)
  "Call FUNCTION for each line of rectangle with corners at START, END.
If COERCE-TABS is non-nil, convert multi-column characters
that span the starting or ending columns on any line
to multiple spaces before calling FUNCTION.
FUNCTION is called with three arguments:
 position of start of segment of this line within the rectangle,
 number of columns that belong to rectangle but are before that position,
 number of columns that belong to rectangle but are after point.
Point is at the end of the segment of this line within the rectangle."
  (let (startcol startlinepos endcol endlinepos)
    (save-excursion
     (goto-char start)
     (setq startcol (current-column))
     (beginning-of-line)
     (setq startlinepos (point)))
    (save-excursion
     (goto-char end)
     (setq endcol (current-column))
     (forward-line 1)
     (setq endlinepos (point-marker)))
    (if (< endcol startcol)
57
	(setq startcol (prog1 endcol (setq endcol startcol))))
58 59 60 61
    (save-excursion
     (goto-char startlinepos)
     (while (< (point) endlinepos)
       (let (startpos begextra endextra)
62
	 (if coerce-tabs
63
	     (move-to-column startcol t)
64
	   (move-to-column startcol))
65 66
	 (setq begextra (- (current-column) startcol))
	 (setq startpos (point))
67
	 (if coerce-tabs
68
	     (move-to-column endcol t)
69
	   (move-to-column endcol))
70 71 72 73
	 ;; If we overshot, move back one character
	 ;; so that endextra will be positive.
	 (if (and (not coerce-tabs) (> (current-column) endcol))
	     (backward-char 1))
74 75 76 77 78 79
	 (setq endextra (- endcol (current-column)))
	 (if (< begextra 0)
	     (setq endextra (+ endextra begextra)
		   begextra 0))
	 (funcall function startpos begextra endextra))
       (forward-line 1)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
80 81
    (- endcol startcol)))

82 83 84
(defun apply-on-rectangle (function start end &rest args)
  "Call FUNCTION for each line of rectangle with corners at START, END.
FUNCTION is called with two arguments: the start and end columns of the
85
rectangle, plus ARGS extra arguments.  Point is at the beginning of line when
86 87 88
the function is called.
The final point after the last operation will be returned."
  (let (startcol startpt endcol endpt final-point)
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
    (save-excursion
      (goto-char start)
      (setq startcol (current-column))
      (beginning-of-line)
      (setq startpt (point))
      (goto-char end)
      (setq endcol (current-column))
      (forward-line 1)
      (setq endpt (point-marker))
      ;; ensure the start column is the left one.
      (if (< endcol startcol)
	  (let ((col startcol))
	    (setq startcol endcol endcol col)))
      ;; start looping over lines
      (goto-char startpt)
      (while (< (point) endpt)
	(apply function startcol endcol args)
106
	(setq final-point (point))
107
	(forward-line 1)))
108
    final-point))
109 110

(defun delete-rectangle-line (startcol endcol fill)
111
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
112 113 114
    (delete-region (point)
		   (progn (move-to-column endcol 'coerce)
			  (point)))))
115 116 117

(defun delete-extract-rectangle-line (startcol endcol lines fill)
  (let ((pt (point-at-eol)))
118
    (if (< (move-to-column startcol (if fill t 'coerce)) startcol)
119 120 121 122
	(setcdr lines (cons (spaces-string (- endcol startcol))
			    (cdr lines)))
      ;; else
      (setq pt (point))
123
      (move-to-column endcol t)
124
      (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines))))
125 126
    ))

127 128 129
;; This is actually the only function that needs to do complicated
;; stuff like what's happening in `operate-on-rectangle', because the
;; buffer might be read-only.
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
(defun extract-rectangle-line (startcol endcol lines)
  (let (start end begextra endextra line)
    (move-to-column startcol)
    (setq start (point)
	  begextra (- (current-column) startcol))
    (move-to-column endcol)
    (setq end (point)
	  endextra (- endcol (current-column)))
    (setq line (buffer-substring start (point)))
    (if (< begextra 0)
	(setq endextra (+ endextra begextra)
	      begextra 0))
    (if (< endextra 0)
	(setq endextra 0))
    (goto-char start)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
145 146 147 148 149 150
    (while (search-forward "\t" end t)
      (let ((width (- (current-column)
		      (save-excursion (forward-char -1)
				      (current-column)))))
	(setq line (concat (substring line 0 (- (point) end 1))
			   (spaces-string width)
151 152
			   (substring line (+ (length line)
					      (- (point) end)))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
153 154 155 156
    (if (or (> begextra 0) (> endextra 0))
	(setq line (concat (spaces-string begextra)
			   line
			   (spaces-string endextra))))
157
    (setcdr lines (cons line (cdr lines)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
158 159 160 161 162

(defconst spaces-strings
  '["" " " "  " "   " "    " "     " "      " "       " "        "])

(defun spaces-string (n)
Juanma Barranquero's avatar
Juanma Barranquero committed
163
  "Return a string with N spaces."
Joseph Arceneaux's avatar
Joseph Arceneaux committed
164
  (if (<= n 8) (aref spaces-strings n)
Juanma Barranquero's avatar
Juanma Barranquero committed
165
    (make-string n ?\s)))
166

Jim Blandy's avatar
Jim Blandy committed
167
;;;###autoload
168
(defun delete-rectangle (start end &optional fill)
169 170 171 172 173 174 175 176 177
  "Delete (don't save) text in the region-rectangle.
The same range of columns is deleted in each line starting with the
line where the region begins and ending with the line where the region
ends.

When called from a program the rectangle's corners are START and END.
With a prefix (or a FILL) argument, also fill lines where nothing has
to be deleted."
  (interactive "*r\nP")
178
  (apply-on-rectangle 'delete-rectangle-line start end fill))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
179

Jim Blandy's avatar
Jim Blandy committed
180
;;;###autoload
181
(defun delete-extract-rectangle (start end &optional fill)
182
  "Delete the contents of the rectangle with corners at START and END.
183
Return it as a list of strings, one for each line of the rectangle.
184

185
When called from a program the rectangle's corners are START and END.
186 187 188 189 190
With an optional FILL argument, also fill lines where nothing has to be
deleted."
  (let ((lines (list nil)))
    (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill)
    (nreverse (cdr lines))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
191

Jim Blandy's avatar
Jim Blandy committed
192
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
193
(defun extract-rectangle (start end)
194 195
  "Return the contents of the rectangle with corners at START and END.
Return it as a list of strings, one for each line of the rectangle."
196 197 198
  (let ((lines (list nil)))
    (apply-on-rectangle 'extract-rectangle-line start end lines)
    (nreverse (cdr lines))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
199 200

(defvar killed-rectangle nil
201
  "Rectangle for `yank-rectangle' to insert.")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
202

Jim Blandy's avatar
Jim Blandy committed
203
;;;###autoload
204
(defun kill-rectangle (start end &optional fill)
205 206 207 208
  "Delete the region-rectangle and save it as the last killed one.

When called from a program the rectangle's corners are START and END.
You might prefer to use `delete-extract-rectangle' from a program.
209 210

With a prefix (or a FILL) argument, also fill lines where nothing has to be
211 212 213 214 215 216 217 218 219 220 221
deleted.

If the buffer is read-only, Emacs will beep and refrain from deleting
the rectangle, but put it in the kill ring anyway.  This means that
you can use this command to copy text from a read-only buffer.
\(If the variable `kill-read-only-ok' is non-nil, then this won't
even beep.)"
  (interactive "r\nP")
  (condition-case nil
      (setq killed-rectangle (delete-extract-rectangle start end fill))
    ((buffer-read-only text-read-only)
222
     (setq deactivate-mark t)
223 224 225 226 227
     (setq killed-rectangle (extract-rectangle start end))
     (if kill-read-only-ok
	 (progn (message "Read only text copied to kill ring") nil)
       (barf-if-buffer-read-only)
       (signal 'text-read-only (list (current-buffer)))))))
228

229 230 231 232 233
;;;###autoload
(defun copy-rectangle-as-kill (start end)
  "Copy the region-rectangle and save it as the last killed one."
  (interactive "r")
  (setq killed-rectangle (extract-rectangle start end))
234 235 236
  (setq deactivate-mark t)
  (if (called-interactively-p 'interactive)
      (indicate-copied-region (length (car killed-rectangle)))))
237

Jim Blandy's avatar
Jim Blandy committed
238
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
239 240
(defun yank-rectangle ()
  "Yank the last killed rectangle with upper left corner at point."
241
  (interactive "*")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
242 243
  (insert-rectangle killed-rectangle))

Jim Blandy's avatar
Jim Blandy committed
244
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
245 246
(defun insert-rectangle (rectangle)
  "Insert text of RECTANGLE with upper left corner at point.
247 248
RECTANGLE's first line is inserted at point, its second
line is inserted at a point vertically under point, etc.
249 250 251
RECTANGLE should be a list of strings.
After this command, the mark is at the upper left corner
and point is at the lower right corner."
Joseph Arceneaux's avatar
Joseph Arceneaux committed
252 253 254
  (let ((lines rectangle)
	(insertcolumn (current-column))
	(first t))
255
    (push-mark)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
256 257 258 259 260
    (while lines
      (or first
	  (progn
	   (forward-line 1)
	   (or (bolp) (insert ?\n))
261
	   (move-to-column insertcolumn t)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
262
      (setq first nil)
263
      (insert-for-yank (car lines))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
264 265
      (setq lines (cdr lines)))))

Jim Blandy's avatar
Jim Blandy committed
266
;;;###autoload
267
(defun open-rectangle (start end &optional fill)
268 269 270 271
  "Blank out the region-rectangle, shifting text right.

The text previously in the region is not overwritten by the blanks,
but instead winds up to the right of the rectangle.
272

273
When called from a program the rectangle's corners are START and END.
Juanma Barranquero's avatar
Juanma Barranquero committed
274 275
With a prefix (or a FILL) argument, fill with blanks even if there is
no text on the right side of the rectangle."
276
  (interactive "*r\nP")
277
  (apply-on-rectangle 'open-rectangle-line start end fill)
278
  (goto-char start))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
279

280
(defun open-rectangle-line (startcol endcol fill)
281
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
282 283 284
    (unless (and (not fill)
		 (= (point) (point-at-eol)))
      (indent-to endcol))))
285

286
(defun delete-whitespace-rectangle-line (startcol _endcol fill)
287
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
288
    (unless (= (point) (point-at-eol))
289
      (delete-region (point) (progn (skip-syntax-forward " ") (point))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
290

291 292 293
;;;###autoload
(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name

294
;;;###autoload
295
(defun delete-whitespace-rectangle (start end &optional fill)
296 297 298
  "Delete all whitespace following a specified column in each line.
The left edge of the rectangle specifies the position in each line
at which whitespace deletion should begin.  On each line in the
299
rectangle, all continuous whitespace starting at that column is deleted.
300

301
When called from a program the rectangle's corners are START and END.
302
With a prefix (or a FILL) argument, also fill too short lines."
303
  (interactive "*r\nP")
304 305
  (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill))

306
(defvar string-rectangle-history nil)
307
(defun string-rectangle-line (startcol endcol string delete)
308
  (move-to-column startcol t)
309 310
  (if delete
      (delete-rectangle-line startcol endcol nil))
311
  (insert string))
312

313
;;;###autoload
314 315 316 317 318
(defun string-rectangle (start end string)
  "Replace rectangle contents with STRING on each line.
The length of STRING need not be the same as the rectangle width.

Called from a program, takes three args; START, END and STRING."
319 320 321 322 323
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
324
	   (read-string (format "String rectangle (default %s): "
325 326 327
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
328 329
  (goto-char
   (apply-on-rectangle 'string-rectangle-line start end string t)))
330

331
;;;###autoload
332 333 334 335 336 337 338 339 340
(defalias 'replace-rectangle 'string-rectangle)

;;;###autoload
(defun string-insert-rectangle (start end string)
  "Insert STRING on each line of region-rectangle, shifting text right.

When called from a program, the rectangle's corners are START and END.
The left edge of the rectangle specifies the column for insertion.
This command does not delete or overwrite any existing text."
341 342 343 344 345
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
346
	   (read-string (format "String insert rectangle (default %s): "
347 348 349
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
350 351
  (apply-on-rectangle 'string-rectangle-line start end string nil))

Jim Blandy's avatar
Jim Blandy committed
352
;;;###autoload
353
(defun clear-rectangle (start end &optional fill)
354 355
  "Blank out the region-rectangle.
The text previously in the region is overwritten with blanks.
356

357
When called from a program the rectangle's corners are START and END.
358 359
With a prefix (or a FILL) argument, also fill with blanks the parts of the
rectangle which were empty."
360
  (interactive "*r\nP")
361 362 363
  (apply-on-rectangle 'clear-rectangle-line start end fill))

(defun clear-rectangle-line (startcol endcol fill)
364
  (let ((pt (point-at-eol)))
365
    (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
366 367 368 369 370
      (if (and (not fill)
	       (<= (save-excursion (goto-char pt) (current-column)) endcol))
	  (delete-region (point) pt)
	;; else
	(setq pt (point))
371
	(move-to-column endcol t)
372
	(setq endcol (current-column))
373
	(delete-region pt (point))
374
	(indent-to endcol)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
375

376 377 378
;; Line numbers for `rectangle-number-line-callback'.
(defvar rectangle-number-line-counter)

379
(defun rectangle-number-line-callback (start _end format-string)
380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414
  (move-to-column start t)
  (insert (format format-string rectangle-number-line-counter))
  (setq rectangle-number-line-counter
	(1+ rectangle-number-line-counter)))

(defun rectange--default-line-number-format (start end start-at)
  (concat "%"
	  (int-to-string (length (int-to-string (+ (count-lines start end)
						   start-at))))
	  "d "))

;;;###autoload
(defun rectangle-number-lines (start end start-at &optional format)
  "Insert numbers in front of the region-rectangle.

START-AT, if non-nil, should be a number from which to begin
counting.  FORMAT, if non-nil, should be a format string to pass
to `format' along with the line count.  When called interactively
with a prefix argument, prompt for START-AT and FORMAT."
  (interactive
   (if current-prefix-arg
       (let* ((start (region-beginning))
	      (end   (region-end))
	      (start-at (read-number "Number to count from: " 1)))
	 (list start end start-at
	       (read-string "Format string: "
			    (rectange--default-line-number-format
			     start end start-at))))
     (list (region-beginning) (region-end) 1 nil)))
  (unless format
    (setq format (rectange--default-line-number-format start end start-at)))
  (let ((rectangle-number-line-counter start-at))
    (apply-on-rectangle 'rectangle-number-line-callback
			start end format)))

415 416 417 418 419 420 421 422 423
;;; New rectangle integration with kill-ring.

;; FIXME: lots of known problems with the new rectangle support:
;; - no key binding for mark-rectangle.
;; - no access to the `string-rectangle' functionality.
;; - lots of commands handle the region without paying attention to its
;;   rectangular shape.

(add-hook 'deactivate-mark-hook
424
          (lambda () (rectangle-mark-mode -1)))
425 426 427 428 429 430 431 432

(add-function :around redisplay-highlight-region-function
              #'rectangle--highlight-for-redisplay)
(add-function :around redisplay-unhighlight-region-function
              #'rectangle--unhighlight-for-redisplay)
(add-function :around region-extract-function
              #'rectangle--extract-region)

433 434 435 436 437 438 439 440 441
(defvar rectangle-mark-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [?\C-o] 'open-rectangle)
    (define-key map [?\C-t] 'string-rectangle)
    ;; (define-key map [remap open-line] 'open-rectangle)
    ;; (define-key map [remap transpose-chars] 'string-rectangle)
    map)
  "Keymap used while marking a rectangular region.")

442
;;;###autoload
443 444 445 446 447 448
(define-minor-mode rectangle-mark-mode
  "Toggle the region as rectangular.
Activates the region if needed.  Only lasts until the region is deactivated."
  nil nil nil
  (when rectangle-mark-mode
    (unless (region-active-p) (push-mark-command t))))
449 450

(defun rectangle--extract-region (orig &optional delete)
451
  (if (not rectangle-mark-mode)
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
      (funcall orig delete)
    (let* ((strs (funcall (if delete
                              #'delete-extract-rectangle
                            #'extract-rectangle)
                          (region-beginning) (region-end)))
           (str (mapconcat #'identity strs "\n")))
      (when (eq last-command 'kill-region)
        ;; Try to prevent kill-region from appending this to some
        ;; earlier element.
        (setq last-command 'kill-region-dont-append))
      (when strs
        (put-text-property 0 (length str) 'yank-handler
                           `(rectangle--insert-for-yank ,strs t)
                           str)
        str))))

(defun rectangle--insert-for-yank (strs)
  (push (point) buffer-undo-list)
  (let ((undo-at-start buffer-undo-list))
    (insert-rectangle strs)
    (setq yank-undo-function
          (lambda (_start _end)
            (undo-start)
            (setcar undo-at-start nil)  ;Turn it into a boundary.
            (while (not (eq pending-undo-list (cdr undo-at-start)))
              (undo-more 1))))))

(defun rectangle--highlight-for-redisplay (orig start end window rol)
  (cond
481
   ((not rectangle-mark-mode)
482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542
    (funcall orig start end window rol))
   ((and (eq 'rectangle (car-safe rol))
         (eq (nth 1 rol) (buffer-modified-tick))
         (eq start (nth 2 rol))
         (eq end (nth 3 rol)))
    rol)
   (t
    (save-excursion
      (let* ((nrol nil)
             (old (if (eq 'rectangle (car-safe rol))
                      (nthcdr 4 rol)
                    (funcall redisplay-unhighlight-region-function rol)
                    nil))
             (ptcol (progn (goto-char start) (current-column)))
             (markcol (progn (goto-char end) (current-column)))
             (leftcol  (min ptcol markcol))
             (rightcol (max ptcol markcol)))
        (goto-char start)
        (while (< (point) end)
          (let* ((mleft (move-to-column leftcol))
                 (left (point))
                 (mright (move-to-column rightcol))
                 (right (point))
                 (ol
                  (if (not old)
                      (let ((ol (make-overlay left right)))
                        (overlay-put ol 'window window)
                        (overlay-put ol 'face 'region)
                        ol)
                    (let ((ol (pop old)))
                      (move-overlay ol left right (current-buffer))
                      ol))))
            ;; `move-to-column' may stop before the column (if bumping into
            ;; EOL) or overshoot it a little, when column is in the middle
            ;; of a char.
            (cond
             ((< mleft leftcol)         ;`leftcol' is past EOL.
              (overlay-put ol 'before-string
                           (spaces-string (- leftcol mleft)))
              (setq mright (max mright leftcol)))
             ((and (> mleft leftcol)    ;`leftcol' is in the middle of a char.
                   (eq (char-before left) ?\t))
              (setq left (1- left))
              (move-overlay ol left right)
              (goto-char left)
              (overlay-put ol 'before-string
                           (spaces-string (- leftcol (current-column)))))
             ((overlay-get ol 'before-string)
              (overlay-put ol 'before-string nil)))
            (cond
             ((< mright rightcol)       ;`rightcol' is past EOL.
              (let ((str (make-string (- rightcol mright) ?\s)))
                (put-text-property 0 (length str) 'face 'region str)
                ;; If cursor happens to be here, draw it *before* rather than
                ;; after this highlighted pseudo-text.
                (put-text-property 0 1 'cursor t str)
                (overlay-put ol 'after-string str)))
             ((and (> mright rightcol)  ;`rightcol' is in the middle of a char.
                   (eq (char-before right) ?\t))
              (setq right (1- right))
              (move-overlay ol left right)
543 544 545 546 547 548 549 550 551 552 553
	      (if (= rightcol leftcol)
		  (overlay-put ol 'after-string nil)
		(goto-char right)
		(let ((str (make-string
			    (- rightcol (max leftcol (current-column))) ?\s)))
		  (put-text-property 0 (length str) 'face 'region str)
		  (when (= left right)
		    ;; If cursor happens to be here, draw it *before* rather
		    ;; than after this highlighted pseudo-text.
		    (put-text-property 0 1 'cursor 1 str))
		  (overlay-put ol 'after-string str))))
554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572
             ((overlay-get ol 'after-string)
              (overlay-put ol 'after-string nil)))
            (when (= leftcol rightcol)
              ;; Make zero-width rectangles visible!
              (overlay-put ol 'after-string
                           (concat (propertize " "
                                               'face '(region (:height 0.2)))
                                   (overlay-get ol 'after-string))))
            (push ol nrol))
          (forward-line 1))
        (mapc #'delete-overlay old)
        `(rectangle ,(buffer-modified-tick) ,start ,end ,@nrol))))))

(defun rectangle--unhighlight-for-redisplay (orig rol)
  (if (not (eq 'rectangle (car-safe rol)))
      (funcall orig rol)
    (mapc #'delete-overlay (nthcdr 4 rol))
    (setcar (cdr rol) nil)))

573
(provide 'rect)
Eric S. Raymond's avatar
Eric S. Raymond committed
574 575

;;; rect.el ends here