rect.el 33.2 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-2014 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 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
  (let ((cw (window-parameter window 'rectangle--point-crutches)))
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 106 107 108 109 110 111 112 113 114 115
    (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
      (if rectangle--mark-crutches (setq rectangle--mark-crutches nil))
      (cons (progn (goto-char start) (current-column))
            (progn (goto-char end) (current-column)))))))

(defun rectangle--col-pos (col kind)
  (let ((c (move-to-column col)))
    (if (= c col)
        (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
116
      ;; If move-to-column overshot, move back one char so we're
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
      ;; 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
141

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

(defun delete-rectangle-line (startcol endcol fill)
171
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
172 173 174
    (delete-region (point)
		   (progn (move-to-column endcol 'coerce)
			  (point)))))
175 176 177

(defun delete-extract-rectangle-line (startcol endcol lines fill)
  (let ((pt (point-at-eol)))
178
    (if (< (move-to-column startcol (if fill t 'coerce)) startcol)
179 180 181 182
	(setcdr lines (cons (spaces-string (- endcol startcol))
			    (cdr lines)))
      ;; else
      (setq pt (point))
183
      (move-to-column endcol t)
184
      (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines))))
185 186
    ))

187 188 189
;; 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.
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
(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
205 206 207 208 209 210
    (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)
211 212
			   (substring line (+ (length line)
					      (- (point) end)))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
213 214 215 216
    (if (or (> begextra 0) (> endextra 0))
	(setq line (concat (spaces-string begextra)
			   line
			   (spaces-string endextra))))
217
    (setcdr lines (cons line (cdr lines)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
218 219 220 221 222

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

(defun spaces-string (n)
Juanma Barranquero's avatar
Juanma Barranquero committed
223
  "Return a string with N spaces."
Joseph Arceneaux's avatar
Joseph Arceneaux committed
224
  (if (<= n 8) (aref spaces-strings n)
Juanma Barranquero's avatar
Juanma Barranquero committed
225
    (make-string n ?\s)))
226

Jim Blandy's avatar
Jim Blandy committed
227
;;;###autoload
228
(defun delete-rectangle (start end &optional fill)
229 230 231 232 233 234 235 236 237
  "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")
238
  (apply-on-rectangle 'delete-rectangle-line start end fill))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
239

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

245
When called from a program the rectangle's corners are START and END.
246 247 248 249 250
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
251

Jim Blandy's avatar
Jim Blandy committed
252
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
253
(defun extract-rectangle (start end)
254 255
  "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."
256 257 258
  (let ((lines (list nil)))
    (apply-on-rectangle 'extract-rectangle-line start end lines)
    (nreverse (cdr lines))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
259 260

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

Jim Blandy's avatar
Jim Blandy committed
263
;;;###autoload
264
(defun kill-rectangle (start end &optional fill)
265 266 267 268
  "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.
269 270

With a prefix (or a FILL) argument, also fill lines where nothing has to be
271 272 273 274 275 276 277 278 279 280 281
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)
282
     (setq deactivate-mark t)
283 284 285 286 287
     (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)))))))
288

289 290 291 292 293
;;;###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))
294 295 296
  (setq deactivate-mark t)
  (if (called-interactively-p 'interactive)
      (indicate-copied-region (length (car killed-rectangle)))))
297

Jim Blandy's avatar
Jim Blandy committed
298
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
299 300
(defun yank-rectangle ()
  "Yank the last killed rectangle with upper left corner at point."
301
  (interactive "*")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
302 303
  (insert-rectangle killed-rectangle))

Jim Blandy's avatar
Jim Blandy committed
304
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
305 306
(defun insert-rectangle (rectangle)
  "Insert text of RECTANGLE with upper left corner at point.
307 308
RECTANGLE's first line is inserted at point, its second
line is inserted at a point vertically under point, etc.
309 310 311
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
312 313 314
  (let ((lines rectangle)
	(insertcolumn (current-column))
	(first t))
315
    (push-mark)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
316 317 318 319 320
    (while lines
      (or first
	  (progn
	   (forward-line 1)
	   (or (bolp) (insert ?\n))
321
	   (move-to-column insertcolumn t)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
322
      (setq first nil)
323
      (insert-for-yank (car lines))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
324 325
      (setq lines (cdr lines)))))

Jim Blandy's avatar
Jim Blandy committed
326
;;;###autoload
327
(defun open-rectangle (start end &optional fill)
328 329 330 331
  "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.
332

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

340
(defun open-rectangle-line (startcol endcol fill)
341
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
342 343 344
    (unless (and (not fill)
		 (= (point) (point-at-eol)))
      (indent-to endcol))))
345

346
(defun delete-whitespace-rectangle-line (startcol _endcol fill)
347
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
348
    (unless (= (point) (point-at-eol))
349
      (delete-region (point) (progn (skip-syntax-forward " ") (point))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
350

351 352 353
;;;###autoload
(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name

354
;;;###autoload
355
(defun delete-whitespace-rectangle (start end &optional fill)
356 357 358
  "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
359
rectangle, all continuous whitespace starting at that column is deleted.
360

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

366
(defvar string-rectangle-history nil)
367
(defun string-rectangle-line (startcol endcol string delete)
368
  (move-to-column startcol t)
369 370
  (if delete
      (delete-rectangle-line startcol endcol nil))
371
  (insert string))
372

373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398
(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)))

(defface rectangle-preview-face '((t :inherit region))
  "The face to use for the `string-rectangle' preview.")

(defcustom rectangle-preview t
  "If non-nil, `string-rectangle' will show an-the-fly preview."
  :type 'boolean)

(defun rectangle--string-preview ()
  (let ((str (minibuffer-contents)))
    (when (equal str "")
      (setq str (or (car-safe minibuffer-default)
                    (if (stringp minibuffer-default) minibuffer-default))))
399
    (when str (setq str (propertize str 'face 'region)))
400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
    (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))))))

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

434
;;;###autoload
435 436 437 438 439
(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."
440
  (interactive
441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461
   (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))
462
	   (read-string (format "String rectangle (default %s): "
463 464
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
465
                            (car string-rectangle-history)))))))
466 467
  (goto-char
   (apply-on-rectangle 'string-rectangle-line start end string t)))
468

469
;;;###autoload
470 471 472 473 474 475 476 477 478
(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."
479 480 481 482 483
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
484
	   (read-string (format "String insert rectangle (default %s): "
485 486 487
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
488 489
  (apply-on-rectangle 'string-rectangle-line start end string nil))

Jim Blandy's avatar
Jim Blandy committed
490
;;;###autoload
491
(defun clear-rectangle (start end &optional fill)
492 493
  "Blank out the region-rectangle.
The text previously in the region is overwritten with blanks.
494

495
When called from a program the rectangle's corners are START and END.
496 497
With a prefix (or a FILL) argument, also fill with blanks the parts of the
rectangle which were empty."
498
  (interactive "*r\nP")
499 500 501
  (apply-on-rectangle 'clear-rectangle-line start end fill))

(defun clear-rectangle-line (startcol endcol fill)
502
  (let ((pt (point-at-eol)))
503
    (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
504 505 506 507 508
      (if (and (not fill)
	       (<= (save-excursion (goto-char pt) (current-column)) endcol))
	  (delete-region (point) pt)
	;; else
	(setq pt (point))
509
	(move-to-column endcol t)
510
	(setq endcol (current-column))
511
	(delete-region pt (point))
512
	(indent-to endcol)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
513

514 515 516
;; Line numbers for `rectangle-number-line-callback'.
(defvar rectangle-number-line-counter)

517
(defun rectangle-number-line-callback (start _end format-string)
518 519 520 521 522
  (move-to-column start t)
  (insert (format format-string rectangle-number-line-counter))
  (setq rectangle-number-line-counter
	(1+ rectangle-number-line-counter)))

523
(defun rectangle--default-line-number-format (start end start-at)
524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543
  (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: "
544
			    (rectangle--default-line-number-format
545 546 547
			     start end start-at))))
     (list (region-beginning) (region-end) 1 nil)))
  (unless format
548
    (setq format (rectangle--default-line-number-format start end start-at)))
549 550 551 552
  (let ((rectangle-number-line-counter start-at))
    (apply-on-rectangle 'rectangle-number-line-callback
			start end format)))

553 554
;;; New rectangle integration with kill-ring.

555
;; FIXME: known problems with the new rectangle support:
556 557 558 559 560 561 562 563 564 565
;; - 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)

566 567 568 569
(defvar rectangle-mark-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [?\C-o] 'open-rectangle)
    (define-key map [?\C-t] 'string-rectangle)
570 571 572 573 574 575
    (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))))
576 577 578
    map)
  "Keymap used while marking a rectangular region.")

579
;;;###autoload
580 581 582 583
(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
584
  (rectangle--reset-crutches)
585
  (when rectangle-mark-mode
586 587
    (add-hook 'deactivate-mark-hook
              (lambda () (rectangle-mark-mode -1)))
588 589
    (unless (region-active-p)
      (push-mark)
Bastien Guerry's avatar
Bastien Guerry committed
590 591
      (activate-mark)
      (message "Mark set (rectangle mode)"))))
592

593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 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
(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))
    (let ((col (rectangle--point-col (point))))
      (while (> n 0)
        (let* ((bol (line-beginning-position))
               (eol (line-end-position))
               (curcol (current-column))
               (nextcol
                (condition-case nil
                    (save-excursion
                      (funcall cmd 1)
                      (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))
              (setq col (if (< col nextcol) (+ col n) (- col n)) n 0))))))
      ;; 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)))


683
(defun rectangle--extract-region (orig &optional delete)
684
  (if (not rectangle-mark-mode)
685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711
      (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))))))

712 713 714 715 716
(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))))

717 718
(defun rectangle--highlight-for-redisplay (orig start end window rol)
  (cond
719
   ((not rectangle-mark-mode)
720
    (funcall orig start end window rol))
721
   (rectangle--inhibit-region-highlight
722
    (funcall redisplay-unhighlight-region-function rol)
723
    nil)
724
   ((and (eq 'rectangle (car-safe rol))
725
         (eq (nth 1 rol) (buffer-chars-modified-tick))
726
         (eq start (nth 2 rol))
727 728
         (eq end (nth 3 rol))
         (equal (rectangle--crutches) (nth 4 rol)))
729 730 731 732 733
    rol)
   (t
    (save-excursion
      (let* ((nrol nil)
             (old (if (eq 'rectangle (car-safe rol))
734
                      (nthcdr 5 rol)
735
                    (funcall redisplay-unhighlight-region-function rol)
736
                    nil)))
737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788
        (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)
                           (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 (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)))
789
                   (put-text-property 0 (length str) 'face 'region str)
790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814
                   ;; 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)))
                     (put-text-property 0 (length str) 'face 'region str)
                     (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 " "
                                                  'face '(region (:height 0.2)))
                                      (overlay-get ol 'after-string))))
               (push ol nrol)))
           start end))
815
        (mapc #'delete-overlay old)
816 817 818
        `(rectangle ,(buffer-chars-modified-tick)
                    ,start ,end ,(rectangle--crutches)
                    ,@nrol))))))
819 820 821 822

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

826
(provide 'rect)
Eric S. Raymond's avatar
Eric S. Raymond committed
827 828

;;; rect.el ends here