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

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

Paul Eggert's avatar
Paul Eggert committed
5
;; Maintainer: Didier Verna <didier@didierverna.net>
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 <https://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
;; ### NOTE: this file was almost completely rewritten by Didier Verna
Paul Eggert's avatar
Paul Eggert committed
30
;; in July 1999.
31

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

34 35
(eval-when-compile (require 'cl-lib))

36 37
(defgroup rectangle nil
  "Operations on rectangles."
Stefan Monnier's avatar
Stefan Monnier committed
38
  :version "25.1"
39 40
  :group 'editing)

41
;; FIXME: this function should be replaced by `apply-on-rectangle'
Joseph Arceneaux's avatar
Joseph Arceneaux committed
42 43 44 45 46 47 48 49 50 51
(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."
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
  (apply-on-rectangle
   (lambda (startcol endcol)
     (let (startpos begextra endextra)
       (move-to-column startcol coerce-tabs)
       (setq begextra (- (current-column) startcol))
       (setq startpos (point))
       (move-to-column endcol coerce-tabs)
       ;; If we overshot, move back one character
       ;; so that endextra will be positive.
       (if (and (not coerce-tabs) (> (current-column) endcol))
           (backward-char 1))
       (setq endextra (- endcol (current-column)))
       (if (< begextra 0)
           (setq endextra (+ endextra begextra)
                 begextra 0))
       (funcall function startpos begextra endextra)))
   start end))

;;; Crutches to let rectangle's corners be where point can't be
;; (e.g. in the middle of a TAB, or past the EOL).

(defvar-local rectangle--mark-crutches nil
  "(POS . COL) to override the column to use for the mark.")

76
(defun rectangle--pos-cols (start end &optional window)
77 78 79
  ;; At this stage, we don't know which of start/end is point/mark :-(
  ;; And in case start=end, it might still be that point and mark have
  ;; different crutches!
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
  (save-excursion
    (let ((cw (window-parameter window 'rectangle--point-crutches)))
      (cond
       ((eq start (car cw))
        (let ((sc (cdr cw))
              (ec (if (eq end (car rectangle--mark-crutches))
                      (cdr rectangle--mark-crutches)
                    (if rectangle--mark-crutches
                        (setq rectangle--mark-crutches nil))
                    (goto-char end) (current-column))))
          (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec))))
       ((eq end (car cw))
        (if (eq start (car rectangle--mark-crutches))
            (cons (cdr rectangle--mark-crutches) (cdr cw))
          (if rectangle--mark-crutches (setq rectangle--mark-crutches nil))
          (cons (progn (goto-char start) (current-column)) (cdr cw))))
       ((progn
          (if cw (setf (window-parameter nil 'rectangle--point-crutches) nil))
          (eq start (car rectangle--mark-crutches)))
        (let ((sc (cdr rectangle--mark-crutches))
              (ec (progn (goto-char end) (current-column))))
          (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec))))
       ((eq end (car rectangle--mark-crutches))
        (cons (progn (goto-char start) (current-column))
              (cdr rectangle--mark-crutches)))
       (t
106
        (if rectangle--mark-crutches (setq rectangle--mark-crutches nil))
107 108
        (cons (progn (goto-char start) (current-column))
              (progn (goto-char end) (current-column))))))))
109 110 111

(defun rectangle--col-pos (col kind)
  (let ((c (move-to-column col)))
112
    (if (and (= c col) (not (eolp)))
113 114 115 116
        (if (eq kind 'point)
            (if (window-parameter nil 'rectangle--point-crutches)
                (setf (window-parameter nil 'rectangle--point-crutches) nil))
          (if rectangle--mark-crutches (setq rectangle--mark-crutches nil)))
Paul Eggert's avatar
Paul Eggert committed
117
      ;; If move-to-column overshot, move back one char so we're
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
      ;; at the position where rectangle--highlight-for-redisplay
      ;; will add the overlay (so that the cursor can be drawn at the
      ;; right place).
      (when (> c col) (forward-char -1))
      (setf (if (eq kind 'point)
                (window-parameter nil 'rectangle--point-crutches)
              rectangle--mark-crutches)
            (cons (point) col)))))

(defun rectangle--point-col (pos)
  (let ((pc (window-parameter nil 'rectangle--point-crutches)))
    (if (eq pos (car pc)) (cdr pc)
      (goto-char pos)
      (current-column))))

(defun rectangle--crutches ()
  (cons rectangle--mark-crutches
        (window-parameter nil 'rectangle--point-crutches)))
(defun rectangle--reset-crutches ()
  (kill-local-variable 'rectangle--mark-crutches)
  (if (window-parameter nil 'rectangle--point-crutches)
      (setf (window-parameter nil 'rectangle--point-crutches) nil)))

;;; Rectangle operations.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
142

143 144 145
(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
146
rectangle, plus ARGS extra arguments.  Point is at the beginning of line when
147 148
the function is called.
The final point after the last operation will be returned."
149 150 151 152 153 154 155 156 157
  (save-excursion
    (let* ((cols (rectangle--pos-cols start end))
           (startcol (car cols))
           (endcol (cdr cols))
           (startpt (progn (goto-char start) (line-beginning-position)))
           (endpt (progn (goto-char end)
                         (copy-marker (line-end-position))))
           final-point)
      ;; Ensure the start column is the left one.
158 159 160
      (if (< endcol startcol)
	  (let ((col startcol))
	    (setq startcol endcol endcol col)))
161
      ;; Start looping over lines.
162
      (goto-char startpt)
163 164 165 166
      (while
          (progn
            (apply function startcol endcol args)
            (setq final-point (point))
167
            (and (zerop (forward-line 1)) (bolp)
168 169
                 (<= (point) endpt))))
      final-point)))
170

171 172 173
(defun rectangle-position-as-coordinates (position)
   "Return cons of the column and line values of POSITION.
POSITION specifies a position of the current buffer.  The value
174
returned has the form (COLUMN . LINE)."
175 176 177
  (save-excursion
    (goto-char position)
    (let ((col (current-column))
178
          (line (line-number-at-pos)))
179 180 181 182 183
      (cons col line))))

(defun rectangle-intersect-p (pos1 size1 pos2 size2)
   "Return non-nil if two rectangles intersect.
POS1 and POS2 specify the positions of the upper-left corners of
184 185 186
the first and second rectangles as conses of the form (COLUMN . LINE).
SIZE1 and SIZE2 specify the dimensions of the first and second
rectangles, as conses of the form (WIDTH . HEIGHT)."
187 188 189 190 191 192 193 194 195 196 197 198 199
  (let ((x1 (car pos1))
        (y1 (cdr pos1))
        (x2 (car pos2))
        (y2 (cdr pos2))
        (w1 (car size1))
        (h1 (cdr size1))
        (w2 (car size2))
        (h2 (cdr size2)))
    (not (or (<= (+ x1 w1) x2)
             (<= (+ x2 w2) x1)
             (<= (+ y1 h1) y2)
             (<= (+ y2 h2) y1)))))

200 201 202 203 204 205 206 207 208 209
(defun rectangle-dimensions (start end)
  "Return the dimensions of the rectangle with corners at START
and END. The returned value has the form of (WIDTH . HEIGHT)."
  (save-excursion
    (let* ((height (1+ (abs (- (line-number-at-pos end)
                               (line-number-at-pos start)))))
           (cols (rectangle--pos-cols start end))
           (width (abs (- (cdr cols) (car cols)))))
      (cons width height))))

210
(defun delete-rectangle-line (startcol endcol fill)
211
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
212 213 214
    (delete-region (point)
		   (progn (move-to-column endcol 'coerce)
			  (point)))))
215 216 217

(defun delete-extract-rectangle-line (startcol endcol lines fill)
  (let ((pt (point-at-eol)))
218
    (if (< (move-to-column startcol (if fill t 'coerce)) startcol)
219 220 221 222
	(setcdr lines (cons (spaces-string (- endcol startcol))
			    (cdr lines)))
      ;; else
      (setq pt (point))
223
      (move-to-column endcol t)
224
      (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines))))
225 226
    ))

227 228 229
;; 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.
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
(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
245 246 247 248 249 250
    (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)
251 252
			   (substring line (+ (length line)
					      (- (point) end)))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
253 254 255 256
    (if (or (> begextra 0) (> endextra 0))
	(setq line (concat (spaces-string begextra)
			   line
			   (spaces-string endextra))))
257
    (setcdr lines (cons line (cdr lines)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
258 259 260 261 262

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

(defun spaces-string (n)
Juanma Barranquero's avatar
Juanma Barranquero committed
263
  "Return a string with N spaces."
Joseph Arceneaux's avatar
Joseph Arceneaux committed
264
  (if (<= n 8) (aref spaces-strings n)
Juanma Barranquero's avatar
Juanma Barranquero committed
265
    (make-string n ?\s)))
266

Jim Blandy's avatar
Jim Blandy committed
267
;;;###autoload
268
(defun delete-rectangle (start end &optional fill)
269 270 271 272 273 274 275 276 277
  "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")
278
  (apply-on-rectangle 'delete-rectangle-line start end fill))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
279

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

285
When called from a program the rectangle's corners are START and END.
286 287 288 289 290
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
291

Jim Blandy's avatar
Jim Blandy committed
292
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
293
(defun extract-rectangle (start end)
294 295
  "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."
296 297 298
  (let ((lines (list nil)))
    (apply-on-rectangle 'extract-rectangle-line start end lines)
    (nreverse (cdr lines))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
299

300 301 302 303 304 305 306 307 308 309 310 311 312
(defun extract-rectangle-bounds (start end)
  "Return the bounds of the rectangle with corners at START and END.
Return it as a list of (START . END) positions, one for each line of
the rectangle."
  (let (bounds)
    (apply-on-rectangle
     (lambda (startcol endcol)
       (move-to-column startcol)
       (push (cons (prog1 (point) (move-to-column endcol)) (point))
	     bounds))
     start end)
    (nreverse bounds)))

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

Jim Blandy's avatar
Jim Blandy committed
316
;;;###autoload
317
(defun kill-rectangle (start end &optional fill)
318 319 320 321
  "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.
322 323

With a prefix (or a FILL) argument, also fill lines where nothing has to be
324 325 326
deleted.

If the buffer is read-only, Emacs will beep and refrain from deleting
327
the rectangle, but put it in `killed-rectangle' anyway.  This means that
328 329 330 331 332 333 334
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)
335
     (setq deactivate-mark t)
336 337
     (setq killed-rectangle (extract-rectangle start end))
     (if kill-read-only-ok
338
         (progn (message "Read only text copied to `killed-rectangle'") nil)
339 340
       (barf-if-buffer-read-only)
       (signal 'text-read-only (list (current-buffer)))))))
341

342 343 344 345 346
;;;###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))
347 348 349
  (setq deactivate-mark t)
  (if (called-interactively-p 'interactive)
      (indicate-copied-region (length (car killed-rectangle)))))
350

Jim Blandy's avatar
Jim Blandy committed
351
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
352 353
(defun yank-rectangle ()
  "Yank the last killed rectangle with upper left corner at point."
354
  (interactive "*")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
355 356
  (insert-rectangle killed-rectangle))

Jim Blandy's avatar
Jim Blandy committed
357
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
358 359
(defun insert-rectangle (rectangle)
  "Insert text of RECTANGLE with upper left corner at point.
360 361
RECTANGLE's first line is inserted at point, its second
line is inserted at a point vertically under point, etc.
362 363 364
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
365 366 367
  (let ((lines rectangle)
	(insertcolumn (current-column))
	(first t))
368
    (push-mark)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
369 370 371 372 373
    (while lines
      (or first
	  (progn
	   (forward-line 1)
	   (or (bolp) (insert ?\n))
374
	   (move-to-column insertcolumn t)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
375
      (setq first nil)
376
      (insert-for-yank (car lines))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
377 378
      (setq lines (cdr lines)))))

Jim Blandy's avatar
Jim Blandy committed
379
;;;###autoload
380
(defun open-rectangle (start end &optional fill)
381 382 383 384
  "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.
385

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

393
(defun open-rectangle-line (startcol endcol fill)
394
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
395 396 397
    (unless (and (not fill)
		 (= (point) (point-at-eol)))
      (indent-to endcol))))
398

399
(defun delete-whitespace-rectangle-line (startcol _endcol fill)
400
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
401
    (unless (= (point) (point-at-eol))
402 403
      (delete-region (point) (progn (skip-syntax-forward " " (point-at-eol))
				    (point))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
404

405 406 407
;;;###autoload
(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name

408
;;;###autoload
409
(defun delete-whitespace-rectangle (start end &optional fill)
410 411 412
  "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
Lars Ingebrigtsen's avatar
Doc fix  
Lars Ingebrigtsen committed
413
rectangle, all contiguous whitespace starting at that column is deleted.
414

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

420
(defvar string-rectangle-history nil)
421
(defun string-rectangle-line (startcol endcol string delete)
422
  (move-to-column startcol t)
423 424
  (if delete
      (delete-rectangle-line startcol endcol nil))
425
  (insert string))
426

427 428 429 430 431 432 433 434 435 436 437 438 439 440
(defvar-local rectangle--string-preview-state nil)
(defvar-local rectangle--string-preview-window nil)

(defun rectangle--string-flush-preview ()
  (mapc #'delete-overlay (nthcdr 3 rectangle--string-preview-state))
  (setf (nthcdr 3 rectangle--string-preview-state) nil))

(defun rectangle--string-erase-preview ()
  (with-selected-window rectangle--string-preview-window
    (rectangle--string-flush-preview)))

(defun rectangle--space-to (col)
  (propertize " " 'display `(space :align-to ,col)))

441 442 443
(defface rectangle-preview '((t :inherit region))
  "The face to use for the `string-rectangle' preview."
  :version "25.1")
444 445

(defcustom rectangle-preview t
Mark Oteiza's avatar
Mark Oteiza committed
446
  "If non-nil, `string-rectangle' will show an on-the-fly preview."
Glenn Morris's avatar
Glenn Morris committed
447
  :version "25.1"
448 449 450
  :type 'boolean)

(defun rectangle--string-preview ()
451 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 481 482
  (when rectangle-preview
    (let ((str (minibuffer-contents)))
      (when str (setq str (propertize str 'face 'rectangle-preview)))
      (with-selected-window rectangle--string-preview-window
        (unless (or (null rectangle--string-preview-state)
                    (equal str (car rectangle--string-preview-state)))
          (rectangle--string-flush-preview)
          (apply-on-rectangle
           (lambda (startcol endcol)
             (let* ((sc (move-to-column startcol))
                    (start (if (<= sc startcol) (point)
                             (forward-char -1)
                             (setq sc (current-column))
                             (point)))
                    (ec (move-to-column endcol))
                    (end (point))
                    (ol (make-overlay start end)))
               (push ol (nthcdr 3 rectangle--string-preview-state))
               ;; FIXME: The extra spacing doesn't interact correctly with
               ;; the extra spacing added by the rectangular-region-highlight.
               (when (< sc startcol)
                 (overlay-put ol 'before-string (rectangle--space-to startcol)))
               (let ((as (when (< endcol ec)
                           ;; (rectangle--space-to ec)
                           (spaces-string (- ec endcol))
                           )))
                 (if (= start end)
                     (overlay-put ol 'after-string (if as (concat str as) str))
                   (overlay-put ol 'display str)
                   (if as (overlay-put ol 'after-string as))))))
           (nth 1 rectangle--string-preview-state)
           (nth 2 rectangle--string-preview-state)))))))
483 484 485 486 487

;; FIXME: Should this be turned into inhibit-region-highlight and made to apply
;; to non-rectangular regions as well?
(defvar rectangle--inhibit-region-highlight nil)

488
;;;###autoload
489 490 491 492
(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.

493 494 495 496
When called interactively and option `rectangle-preview' is
non-nil, display the result as the user enters the string into
the minibuffer.

497
Called from a program, takes three args; START, END and STRING."
498
  (interactive
499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519
   (progn
     (make-local-variable 'rectangle--string-preview-state)
     (make-local-variable 'rectangle--inhibit-region-highlight)
     (let* ((buf (current-buffer))
            (win (if (eq (window-buffer) buf) (selected-window)))
            (start (region-beginning))
            (end (region-end))
            (rectangle--string-preview-state `(nil ,start ,end))
            ;; Rectangle-region-highlighting doesn't work well in the presence
            ;; of the preview overlays.  We could work harder to try and make
            ;; it work better, but it's easier to just disable it temporarily.
            (rectangle--inhibit-region-highlight t))
       (barf-if-buffer-read-only)
       (list start end
             (minibuffer-with-setup-hook
                 (lambda ()
                   (setq rectangle--string-preview-window win)
                   (add-hook 'minibuffer-exit-hook
                             #'rectangle--string-erase-preview nil t)
                   (add-hook 'post-command-hook
                             #'rectangle--string-preview nil t))
520 521 522
               (read-string (format "String rectangle (default %s): "
                                    (or (car string-rectangle-history) ""))
                            nil 'string-rectangle-history
523
                            (car string-rectangle-history)))))))
524 525 526 527 528
  ;; If we undo this change, we want to have the point back where we
  ;; are now, and not after the first line in the rectangle (which is
  ;; the first line to be changed by the following command).
  (unless (eq buffer-undo-list t)
    (push (point) buffer-undo-list))
529 530
  (goto-char
   (apply-on-rectangle 'string-rectangle-line start end string t)))
531

532
;;;###autoload
533 534 535 536 537 538 539 540 541
(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."
542 543 544 545 546
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
547
	   (read-string (format "String insert rectangle (default %s): "
548 549 550
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
551 552
  (apply-on-rectangle 'string-rectangle-line start end string nil))

Jim Blandy's avatar
Jim Blandy committed
553
;;;###autoload
554
(defun clear-rectangle (start end &optional fill)
555 556
  "Blank out the region-rectangle.
The text previously in the region is overwritten with blanks.
557

558
When called from a program the rectangle's corners are START and END.
559 560
With a prefix (or a FILL) argument, also fill with blanks the parts of the
rectangle which were empty."
561
  (interactive "*r\nP")
562 563 564
  (apply-on-rectangle 'clear-rectangle-line start end fill))

(defun clear-rectangle-line (startcol endcol fill)
565
  (let ((pt (point-at-eol)))
566
    (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
567 568 569 570 571
      (if (and (not fill)
	       (<= (save-excursion (goto-char pt) (current-column)) endcol))
	  (delete-region (point) pt)
	;; else
	(setq pt (point))
572
	(move-to-column endcol t)
573
	(setq endcol (current-column))
574
	(delete-region pt (point))
575
	(indent-to endcol)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
576

577 578 579
;; Line numbers for `rectangle-number-line-callback'.
(defvar rectangle-number-line-counter)

580
(defun rectangle-number-line-callback (start _end format-string)
581 582 583 584 585
  (move-to-column start t)
  (insert (format format-string rectangle-number-line-counter))
  (setq rectangle-number-line-counter
	(1+ rectangle-number-line-counter)))

586
(defun rectangle--default-line-number-format (start end start-at)
587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606
  (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: "
607
			    (rectangle--default-line-number-format
608 609 610
			     start end start-at))))
     (list (region-beginning) (region-end) 1 nil)))
  (unless format
611
    (setq format (rectangle--default-line-number-format start end start-at)))
612 613 614 615
  (let ((rectangle-number-line-counter start-at))
    (apply-on-rectangle 'rectangle-number-line-callback
			start end format)))

616 617
;;; New rectangle integration with kill-ring.

618
;; FIXME: known problems with the new rectangle support:
619 620 621 622 623 624 625 626 627
;; - lots of commands handle the region without paying attention to its
;;   rectangular shape.

(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)
628 629
(add-function :around region-insert-function
              #'rectangle--insert-region)
630

631 632 633 634
(defvar rectangle-mark-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [?\C-o] 'open-rectangle)
    (define-key map [?\C-t] 'string-rectangle)
635 636 637 638 639 640
    (define-key map [remap exchange-point-and-mark]
      'rectangle-exchange-point-and-mark)
    (dolist (cmd '(right-char left-char forward-char backward-char
                   next-line previous-line))
      (define-key map (vector 'remap cmd)
        (intern (format "rectangle-%s" cmd))))
641 642 643
    map)
  "Keymap used while marking a rectangular region.")

644
;;;###autoload
645 646
(define-minor-mode rectangle-mark-mode
  "Toggle the region as rectangular.
647

648 649
Activates the region if needed.  Only lasts until the region is deactivated."
  nil nil nil
650
  (rectangle--reset-crutches)
651
  (when rectangle-mark-mode
652 653
    (add-hook 'deactivate-mark-hook
              (lambda () (rectangle-mark-mode -1)))
654
    (unless (region-active-p)
655
      (push-mark (point) t t)
Bastien Guerry's avatar
Bastien Guerry committed
656
      (message "Mark set (rectangle mode)"))))
657

658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686
(defun rectangle-exchange-point-and-mark (&optional arg)
  "Like `exchange-point-and-mark' but cycles through the rectangle's corners."
  (interactive "P")
  (if arg
      (progn
        (setq this-command 'exchange-point-and-mark)
        (exchange-point-and-mark arg))
    (let* ((p (point))
           (repeat (eq this-command last-command))
	   (m (mark))
           (p<m (< p m))
           (cols (if p<m (rectangle--pos-cols p m) (rectangle--pos-cols m p)))
           (cp (if p<m (car cols) (cdr cols)))
           (cm (if p<m (cdr cols) (car cols))))
      (if repeat (setq this-command 'exchange-point-and-mark))
      (rectangle--reset-crutches)
      (goto-char p)
      (rectangle--col-pos (if repeat cm cp) 'mark)
      (set-mark (point))
      (goto-char m)
      (rectangle--col-pos (if repeat cp cm) 'point))))

(defun rectangle--*-char (cmd n &optional other-cmd)
  ;; Part of the complexity here is that I'm trying to avoid making assumptions
  ;; about the L2R/R2L direction of text around point, but this is largely
  ;; useless since the rectangles implemented in this file are "logical
  ;; rectangles" and not "visual rectangles", so in the presence of
  ;; bidirectional text things won't work well anyway.
  (if (< n 0) (rectangle--*-char other-cmd (- n))
Eli Zaretskii's avatar
Eli Zaretskii committed
687 688
    (let ((col (rectangle--point-col (point)))
          (step 1))
689 690 691 692 693 694 695
      (while (> n 0)
        (let* ((bol (line-beginning-position))
               (eol (line-end-position))
               (curcol (current-column))
               (nextcol
                (condition-case nil
                    (save-excursion
Eli Zaretskii's avatar
Eli Zaretskii committed
696
                      (funcall cmd step)
697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714
                      (cond
                       ((> bol (point)) (- curcol 1))
                       ((< eol (point)) (+ col (1+ n)))
                       (t (current-column))))
                  (end-of-buffer (+ col (1+ n)))
                  (beginning-of-buffer (- curcol 1))))
               (diff (abs (- nextcol col))))
          (cond
           ((and (< nextcol curcol) (< curcol col))
            (let ((curdiff (- col curcol)))
              (if (<= curdiff n)
                (progn (cl-decf n curdiff) (setq col curcol))
                (setq col (- col n) n 0))))
           ((< nextcol 0) (ding) (setq n 0 col 0)) ;Bumping into BOL!
           ((= nextcol curcol) (funcall cmd 1))
           (t ;; (> nextcol curcol)
            (if (<= diff n)
                (progn (cl-decf n diff) (setq col nextcol))
Eli Zaretskii's avatar
Eli Zaretskii committed
715 716
              (setq col (if (< col nextcol) (+ col n) (- col n)) n 0))))
          (setq step (1+ step))))
717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749
      ;; FIXME: This rectangle--col-pos's move-to-column is wasted!
      (rectangle--col-pos col 'point))))

(defun rectangle-right-char (&optional n)
  "Like `right-char' but steps into wide chars and moves past EOL."
  (interactive "p") (rectangle--*-char #'right-char n #'left-char))
(defun rectangle-left-char (&optional n)
  "Like `left-char' but steps into wide chars and moves past EOL."
  (interactive "p") (rectangle--*-char #'left-char n #'right-char))

(defun rectangle-forward-char (&optional n)
  "Like `forward-char' but steps into wide chars and moves past EOL."
  (interactive "p") (rectangle--*-char #'forward-char n #'backward-char))
(defun rectangle-backward-char (&optional n)
  "Like `backward-char' but steps into wide chars and moves past EOL."
  (interactive "p") (rectangle--*-char #'backward-char n #'forward-char))

(defun rectangle-next-line (&optional n)
  "Like `next-line' but steps into wide chars and moves past EOL.
Ignores `line-move-visual'."
  (interactive "p")
  (let ((col (rectangle--point-col (point))))
    (forward-line n)
    (rectangle--col-pos col 'point)))
(defun rectangle-previous-line (&optional n)
  "Like `previous-line' but steps into wide chars and moves past EOL.
Ignores `line-move-visual'."
  (interactive "p")
  (let ((col (rectangle--point-col (point))))
    (forward-line (- n))
    (rectangle--col-pos col 'point)))


750
(defun rectangle--extract-region (orig &optional delete)
751 752 753 754 755 756
  (cond
   ((not rectangle-mark-mode)
    (funcall orig delete))
   ((eq delete 'bounds)
    (extract-rectangle-bounds (region-beginning) (region-end)))
   (t
757 758 759 760 761 762 763 764 765 766 767 768 769
    (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)
770 771 772 773 774 775 776 777
        str)))))

(defun rectangle--insert-region (orig strings)
  (cond
   ((not rectangle-mark-mode)
    (funcall orig strings))
   (t
    (funcall #'insert-rectangle strings))))
778 779 780 781 782 783 784 785 786 787 788 789

(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))))))

790 791 792 793 794
(defun rectangle--place-cursor (leftcol left str)
  (let ((pc (window-parameter nil 'rectangle--point-crutches)))
    (if (and (eq left (car pc)) (eq leftcol (cdr pc)))
        (put-text-property 0 1 'cursor 1 str))))

795 796
(defun rectangle--highlight-for-redisplay (orig start end window rol)
  (cond
797
   ((not rectangle-mark-mode)
798
    (funcall orig start end window rol))
799
   (rectangle--inhibit-region-highlight
800
    (funcall redisplay-unhighlight-region-function rol)
801
    nil)
802
   ((and (eq 'rectangle (car-safe rol))
803
         (eq (nth 1 rol) (buffer-chars-modified-tick))
804
         (eq start (nth 2 rol))
805 806
         (eq end (nth 3 rol))
         (equal (rectangle--crutches) (nth 4 rol)))
807 808 809 810 811
    rol)
   (t
    (save-excursion
      (let* ((nrol nil)
             (old (if (eq 'rectangle (car-safe rol))
812
                      (nthcdr 5 rol)
813
                    (funcall redisplay-unhighlight-region-function rol)
814
                    nil)))
815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834
        (cl-assert (eq (window-buffer window) (current-buffer)))
        ;; `rectangle--pos-cols' looks up the `selected-window's parameter!
        (with-selected-window window
          (apply-on-rectangle
           (lambda (leftcol rightcol)
             (let* ((mleft (move-to-column leftcol))
                    (left (point))
                    ;; BEWARE: In the presence of other overlays with
                    ;; before/after/display-strings, this happens to move to
                    ;; the column "as if the overlays were not applied", which
                    ;; is sometimes what we want, tho it can be
                    ;; considered a bug in move-to-column (it should arguably
                    ;; pay attention to the before/after-string/display
                    ;; properties when computing the column).
                    (mright (move-to-column rightcol))
                    (right (point))
                    (ol
                     (if (not old)
                         (let ((ol (make-overlay left right)))
                           (overlay-put ol 'window window)
835
                           (overlay-put ol 'face 'region)
836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866
                           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 (rectangle--space-to leftcol))
                 (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 (rectangle--space-to leftcol)))
                ((overlay-get ol 'before-string)
                 (overlay-put ol 'before-string nil)))
               (cond
                ;; While doing rectangle--string-preview, the two sets of
                ;; overlays steps on the other's toes.  I fixed some of the
                ;; problems, but others remain.  The main one is the two
                ;; (rectangle--space-to rightcol) below which try to virtually
                ;; insert missing text, but during "preview", the text is not
                ;; missing (it's provided by preview's own overlay).
                (rectangle--string-preview-state
                 (if (overlay-get ol 'after-string)
                     (overlay-put ol 'after-string nil)))
                ((< mright rightcol)    ;`rightcol' is past EOL.
                 (let ((str (rectangle--space-to rightcol)))
Mark Oteiza's avatar
Mark Oteiza committed
867
                   (put-text-property 0 (length str) 'face 'region str)
868 869 870 871 872 873 874 875 876 877 878
                   ;; If cursor happens to be here, draw it at the right place.
                   (rectangle--place-cursor leftcol left str)
                   (overlay-put ol 'after-string str)))
                ((and (> mright rightcol) ;`rightcol's in the middle of a char.
                      (eq (char-before right) ?\t))
                 (setq right (1- right))
                 (move-overlay ol left right)
                 (if (= rightcol leftcol)
                     (overlay-put ol 'after-string nil)
                   (goto-char right)
                   (let ((str (rectangle--space-to rightcol)))
Mark Oteiza's avatar
Mark Oteiza committed
879
                     (put-text-property 0 (length str) 'face 'region str)
880 881 882 883 884 885 886 887 888
                     (when (= left right)
                       (rectangle--place-cursor leftcol left str))
                     (overlay-put ol 'after-string str))))
                ((overlay-get ol 'after-string)
                 (overlay-put ol 'after-string nil)))
               (when (and (= leftcol rightcol) (display-graphic-p))
                 ;; Make zero-width rectangles visible!
                 (overlay-put ol 'after-string
                              (concat (propertize " "
Mark Oteiza's avatar
Mark Oteiza committed
889
                                                  'face '(region (:height 0.2)))
890 891 892
                                      (overlay-get ol 'after-string))))
               (push ol nrol)))
           start end))
893
        (mapc #'delete-overlay old)
894 895 896
        `(rectangle ,(buffer-chars-modified-tick)
                    ,start ,end ,(rectangle--crutches)
                    ,@nrol))))))
897 898 899 900

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

904
(provide 'rect)
Eric S. Raymond's avatar
Eric S. Raymond committed
905 906

;;; rect.el ends here