* doc/misc/tramp.texi (Frequently Asked Questions): New item for ad-hoc
[emacs.git] / lisp / rect.el
Commit [+]AuthorDateLineData
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -04001;;; rect.el --- rectangle functions for GNU Emacs -*- lexical-binding:t -*-
6594deb0 Eric S. Raymond1992-05-30 22:12:04 +00002
7e09ef09 Paul Eggert2015-01-01 14:26:41 -08003;; Copyright (C) 1985, 1999-2015 Free Software Foundation, Inc.
9750e079 Eric S. Raymond1992-07-22 04:22:30 +00004
aa01bed1 Eli Zaretskii2001-10-03 10:52:47 +00005;; Maintainer: Didier Verna <didier@xemacs.org>
d7b4d18f Eric S. Raymond1992-07-17 20:24:00 +00006;; Keywords: internal
bd78fa1d Chong Yidong2010-08-29 12:17:13 -04007;; Package: emacs
4821e2af Eric S. Raymond1992-07-15 23:29:10 +00008
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +00009;; This file is part of GNU Emacs.
10
eb3fa2cf Glenn Morris2008-05-06 08:06:51 +000011;; GNU Emacs is free software: you can redistribute it and/or modify
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +000012;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM
Glenn Morris2008-05-06 08:06:51 +000013;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +000015
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
eb3fa2cf Glenn Morris2008-05-06 08:06:51 +000022;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +000023
edbd2f74
ER
Eric S. Raymond1993-03-22 05:42:35 +000024;;; Commentary:
25
e037c34c Dave Love1999-08-23 14:28:34 +000026;; This package provides the operations on rectangles that are documented
edbd2f74
ER
Eric S. Raymond1993-03-22 05:42:35 +000027;; in the Emacs manual.
28
5614fd56
CY
Chong Yidong2010-12-15 10:05:38 +080029;; ### NOTE: this file was almost completely rewritten by Didier Verna
30;; <didier@xemacs.org> in July 1999.
e417c66f Richard M. Stallman1999-08-03 18:36:16 +000031
4821e2af Eric S. Raymond1992-07-15 23:29:10 +000032;;; Code:
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +000033
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -040034(eval-when-compile (require 'cl-lib))
35
5139e960
SM
Stefan Monnier2014-06-17 15:33:58 -040036(defgroup rectangle nil
37 "Operations on rectangles."
cbdc06f3 Stefan Monnier2014-09-29 14:14:08 -040038 :version "25.1"
5139e960
SM
Stefan Monnier2014-06-17 15:33:58 -040039 :group 'editing)
40
5614fd56 Chong Yidong2010-12-15 10:05:38 +080041;; FIXME: this function should be replaced by `apply-on-rectangle'
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +000042(defun operate-on-rectangle (function start end coerce-tabs)
43 "Call FUNCTION for each line of rectangle with corners at START, END.
44If COERCE-TABS is non-nil, convert multi-column characters
45that span the starting or ending columns on any line
46to multiple spaces before calling FUNCTION.
47FUNCTION is called with three arguments:
48 position of start of segment of this line within the rectangle,
49 number of columns that belong to rectangle but are before that position,
50 number of columns that belong to rectangle but are after point.
51Point is at the end of the segment of this line within the rectangle."
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -040052 (apply-on-rectangle
53 (lambda (startcol endcol)
54 (let (startpos begextra endextra)
55 (move-to-column startcol coerce-tabs)
56 (setq begextra (- (current-column) startcol))
57 (setq startpos (point))
58 (move-to-column endcol coerce-tabs)
59 ;; If we overshot, move back one character
60 ;; so that endextra will be positive.
61 (if (and (not coerce-tabs) (> (current-column) endcol))
62 (backward-char 1))
63 (setq endextra (- endcol (current-column)))
64 (if (< begextra 0)
65 (setq endextra (+ endextra begextra)
66 begextra 0))
67 (funcall function startpos begextra endextra)))
68 start end))
69
70;;; Crutches to let rectangle's corners be where point can't be
71;; (e.g. in the middle of a TAB, or past the EOL).
72
73(defvar-local rectangle--mark-crutches nil
74 "(POS . COL) to override the column to use for the mark.")
75
5139e960 Stefan Monnier2014-06-17 15:33:58 -040076(defun rectangle--pos-cols (start end &optional window)
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -040077 ;; At this stage, we don't know which of start/end is point/mark :-(
78 ;; And in case start=end, it might still be that point and mark have
79 ;; different crutches!
5139e960 Stefan Monnier2014-06-17 15:33:58 -040080 (let ((cw (window-parameter window 'rectangle--point-crutches)))
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -040081 (cond
82 ((eq start (car cw))
83 (let ((sc (cdr cw))
84 (ec (if (eq end (car rectangle--mark-crutches))
85 (cdr rectangle--mark-crutches)
86 (if rectangle--mark-crutches
87 (setq rectangle--mark-crutches nil))
88 (goto-char end) (current-column))))
89 (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec))))
90 ((eq end (car cw))
91 (if (eq start (car rectangle--mark-crutches))
92 (cons (cdr rectangle--mark-crutches) (cdr cw))
93 (if rectangle--mark-crutches (setq rectangle--mark-crutches nil))
94 (cons (progn (goto-char start) (current-column)) (cdr cw))))
95 ((progn
96 (if cw (setf (window-parameter nil 'rectangle--point-crutches) nil))
97 (eq start (car rectangle--mark-crutches)))
98 (let ((sc (cdr rectangle--mark-crutches))
99 (ec (progn (goto-char end) (current-column))))
100 (if (eq start end) (cons (min sc ec) (max sc ec)) (cons sc ec))))
101 ((eq end (car rectangle--mark-crutches))
102 (cons (progn (goto-char start) (current-column))
103 (cdr rectangle--mark-crutches)))
104 (t
105 (if rectangle--mark-crutches (setq rectangle--mark-crutches nil))
106 (cons (progn (goto-char start) (current-column))
107 (progn (goto-char end) (current-column)))))))
108
109(defun rectangle--col-pos (col kind)
110 (let ((c (move-to-column col)))
111 (if (= c col)
112 (if (eq kind 'point)
113 (if (window-parameter nil 'rectangle--point-crutches)
114 (setf (window-parameter nil 'rectangle--point-crutches) nil))
115 (if rectangle--mark-crutches (setq rectangle--mark-crutches nil)))
0f2ed592 Paul Eggert2014-09-11 12:44:25 -0700116 ;; If move-to-column overshot, move back one char so we're
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400117 ;; at the position where rectangle--highlight-for-redisplay
118 ;; will add the overlay (so that the cursor can be drawn at the
119 ;; right place).
120 (when (> c col) (forward-char -1))
121 (setf (if (eq kind 'point)
122 (window-parameter nil 'rectangle--point-crutches)
123 rectangle--mark-crutches)
124 (cons (point) col)))))
125
126(defun rectangle--point-col (pos)
127 (let ((pc (window-parameter nil 'rectangle--point-crutches)))
128 (if (eq pos (car pc)) (cdr pc)
129 (goto-char pos)
130 (current-column))))
131
132(defun rectangle--crutches ()
133 (cons rectangle--mark-crutches
134 (window-parameter nil 'rectangle--point-crutches)))
135(defun rectangle--reset-crutches ()
136 (kill-local-variable 'rectangle--mark-crutches)
137 (if (window-parameter nil 'rectangle--point-crutches)
138 (setf (window-parameter nil 'rectangle--point-crutches) nil)))
139
140;;; Rectangle operations.
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000141
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000142(defun apply-on-rectangle (function start end &rest args)
143 "Call FUNCTION for each line of rectangle with corners at START, END.
144FUNCTION is called with two arguments: the start and end columns of the
e037c34c Dave Love1999-08-23 14:28:34 +0000145rectangle, plus ARGS extra arguments. Point is at the beginning of line when
7509a874
LMI
Lars Magne Ingebrigtsen2011-07-14 17:23:08 +0200146the function is called.
147The final point after the last operation will be returned."
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400148 (save-excursion
149 (let* ((cols (rectangle--pos-cols start end))
150 (startcol (car cols))
151 (endcol (cdr cols))
152 (startpt (progn (goto-char start) (line-beginning-position)))
153 (endpt (progn (goto-char end)
154 (copy-marker (line-end-position))))
155 final-point)
156 ;; Ensure the start column is the left one.
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000157 (if (< endcol startcol)
158 (let ((col startcol))
159 (setq startcol endcol endcol col)))
7e74ad02 Stefan Monnier2014-06-11 17:51:44 -0400160 ;; Start looping over lines.
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000161 (goto-char startpt)
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400162 (while
163 (progn
164 (apply function startcol endcol args)
165 (setq final-point (point))
388b22de Stefan Monnier2014-07-08 22:20:21 -0400166 (and (zerop (forward-line 1)) (bolp)
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400167 (<= (point) endpt))))
168 final-point)))
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000169
170(defun delete-rectangle-line (startcol endcol fill)
b29b5c24 Richard M. Stallman2005-01-29 17:26:39 +0000171 (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
b9e81d0a
SM
Stefan Monnier2001-11-17 00:47:42 +0000172 (delete-region (point)
173 (progn (move-to-column endcol 'coerce)
174 (point)))))
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000175
176(defun delete-extract-rectangle-line (startcol endcol lines fill)
177 (let ((pt (point-at-eol)))
b29b5c24 Richard M. Stallman2005-01-29 17:26:39 +0000178 (if (< (move-to-column startcol (if fill t 'coerce)) startcol)
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000179 (setcdr lines (cons (spaces-string (- endcol startcol))
180 (cdr lines)))
181 ;; else
182 (setq pt (point))
b9e81d0a Stefan Monnier2001-11-17 00:47:42 +0000183 (move-to-column endcol t)
5c831ccd Eli Zaretskii2006-04-08 10:30:52 +0000184 (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines))))
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000185 ))
186
5614fd56
CY
Chong Yidong2010-12-15 10:05:38 +0800187;; This is actually the only function that needs to do complicated
188;; stuff like what's happening in `operate-on-rectangle', because the
189;; buffer might be read-only.
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000190(defun extract-rectangle-line (startcol endcol lines)
191 (let (start end begextra endextra line)
192 (move-to-column startcol)
193 (setq start (point)
194 begextra (- (current-column) startcol))
195 (move-to-column endcol)
196 (setq end (point)
197 endextra (- endcol (current-column)))
198 (setq line (buffer-substring start (point)))
199 (if (< begextra 0)
200 (setq endextra (+ endextra begextra)
201 begextra 0))
202 (if (< endextra 0)
203 (setq endextra 0))
204 (goto-char start)
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000205 (while (search-forward "\t" end t)
206 (let ((width (- (current-column)
207 (save-excursion (forward-char -1)
208 (current-column)))))
209 (setq line (concat (substring line 0 (- (point) end 1))
210 (spaces-string width)
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000211 (substring line (+ (length line)
212 (- (point) end)))))))
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000213 (if (or (> begextra 0) (> endextra 0))
214 (setq line (concat (spaces-string begextra)
215 line
216 (spaces-string endextra))))
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000217 (setcdr lines (cons line (cdr lines)))))
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000218
219(defconst spaces-strings
220 '["" " " " " " " " " " " " " " " " "])
221
222(defun spaces-string (n)
6cda144f Juanma Barranquero2008-11-01 01:24:33 +0000223 "Return a string with N spaces."
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000224 (if (<= n 8) (aref spaces-strings n)
6cda144f Juanma Barranquero2008-11-01 01:24:33 +0000225 (make-string n ?\s)))
f1180544 Juanma Barranquero2003-02-04 12:29:42 +0000226
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000227;;;###autoload
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000228(defun delete-rectangle (start end &optional fill)
e037c34c
DL
Dave Love1999-08-23 14:28:34 +0000229 "Delete (don't save) text in the region-rectangle.
230The same range of columns is deleted in each line starting with the
231line where the region begins and ending with the line where the region
232ends.
233
234When called from a program the rectangle's corners are START and END.
235With a prefix (or a FILL) argument, also fill lines where nothing has
236to be deleted."
237 (interactive "*r\nP")
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000238 (apply-on-rectangle 'delete-rectangle-line start end fill))
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000239
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000240;;;###autoload
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000241(defun delete-extract-rectangle (start end &optional fill)
7db6139a Dave Love1999-08-23 16:14:59 +0000242 "Delete the contents of the rectangle with corners at START and END.
e037c34c Dave Love1999-08-23 14:28:34 +0000243Return it as a list of strings, one for each line of the rectangle.
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000244
e037c34c Dave Love1999-08-23 14:28:34 +0000245When called from a program the rectangle's corners are START and END.
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000246With an optional FILL argument, also fill lines where nothing has to be
247deleted."
248 (let ((lines (list nil)))
249 (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill)
250 (nreverse (cdr lines))))
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000251
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000252;;;###autoload
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000253(defun extract-rectangle (start end)
e037c34c
DL
Dave Love1999-08-23 14:28:34 +0000254 "Return the contents of the rectangle with corners at START and END.
255Return it as a list of strings, one for each line of the rectangle."
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000256 (let ((lines (list nil)))
257 (apply-on-rectangle 'extract-rectangle-line start end lines)
258 (nreverse (cdr lines))))
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000259
260(defvar killed-rectangle nil
e037c34c Dave Love1999-08-23 14:28:34 +0000261 "Rectangle for `yank-rectangle' to insert.")
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000262
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000263;;;###autoload
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000264(defun kill-rectangle (start end &optional fill)
e037c34c
DL
Dave Love1999-08-23 14:28:34 +0000265 "Delete the region-rectangle and save it as the last killed one.
266
267When called from a program the rectangle's corners are START and END.
268You might prefer to use `delete-extract-rectangle' from a program.
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000269
270With a prefix (or a FILL) argument, also fill lines where nothing has to be
5c831ccd
EZ
Eli Zaretskii2006-04-08 10:30:52 +0000271deleted.
272
273If the buffer is read-only, Emacs will beep and refrain from deleting
274the rectangle, but put it in the kill ring anyway. This means that
275you can use this command to copy text from a read-only buffer.
276\(If the variable `kill-read-only-ok' is non-nil, then this won't
277even beep.)"
278 (interactive "r\nP")
279 (condition-case nil
280 (setq killed-rectangle (delete-extract-rectangle start end fill))
281 ((buffer-read-only text-read-only)
2549c068 Chong Yidong2012-07-29 12:45:48 +0800282 (setq deactivate-mark t)
5c831ccd
EZ
Eli Zaretskii2006-04-08 10:30:52 +0000283 (setq killed-rectangle (extract-rectangle start end))
284 (if kill-read-only-ok
285 (progn (message "Read only text copied to kill ring") nil)
286 (barf-if-buffer-read-only)
287 (signal 'text-read-only (list (current-buffer)))))))
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000288
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000289;;;###autoload
be755c79
RT
Reuben Thomas2012-07-14 10:19:07 +0800290(defun copy-rectangle-as-kill (start end)
291 "Copy the region-rectangle and save it as the last killed one."
292 (interactive "r")
293 (setq killed-rectangle (extract-rectangle start end))
2549c068
CY
Chong Yidong2012-07-29 12:45:48 +0800294 (setq deactivate-mark t)
295 (if (called-interactively-p 'interactive)
296 (indicate-copied-region (length (car killed-rectangle)))))
be755c79
RT
Reuben Thomas2012-07-14 10:19:07 +0800297
298;;;###autoload
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000299(defun yank-rectangle ()
300 "Yank the last killed rectangle with upper left corner at point."
e037c34c Dave Love1999-08-23 14:28:34 +0000301 (interactive "*")
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000302 (insert-rectangle killed-rectangle))
303
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000304;;;###autoload
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000305(defun insert-rectangle (rectangle)
306 "Insert text of RECTANGLE with upper left corner at point.
573f9b32
RS
Richard M. Stallman1991-04-12 20:15:51 +0000307RECTANGLE's first line is inserted at point, its second
308line is inserted at a point vertically under point, etc.
23317eac
RS
Richard M. Stallman1992-11-03 22:25:28 +0000309RECTANGLE should be a list of strings.
310After this command, the mark is at the upper left corner
311and point is at the lower right corner."
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000312 (let ((lines rectangle)
313 (insertcolumn (current-column))
314 (first t))
23317eac Richard M. Stallman1992-11-03 22:25:28 +0000315 (push-mark)
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000316 (while lines
317 (or first
318 (progn
319 (forward-line 1)
320 (or (bolp) (insert ?\n))
b9e81d0a Stefan Monnier2001-11-17 00:47:42 +0000321 (move-to-column insertcolumn t)))
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000322 (setq first nil)
afa0467f Richard M. Stallman2002-04-19 00:23:08 +0000323 (insert-for-yank (car lines))
a2535589
JA
Joseph Arceneaux1989-10-31 16:00:07 +0000324 (setq lines (cdr lines)))))
325
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000326;;;###autoload
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000327(defun open-rectangle (start end &optional fill)
e037c34c
DL
Dave Love1999-08-23 14:28:34 +0000328 "Blank out the region-rectangle, shifting text right.
329
330The text previously in the region is not overwritten by the blanks,
331but instead winds up to the right of the rectangle.
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000332
e037c34c Dave Love1999-08-23 14:28:34 +0000333When called from a program the rectangle's corners are START and END.
6cda144f
JB
Juanma Barranquero2008-11-01 01:24:33 +0000334With a prefix (or a FILL) argument, fill with blanks even if there is
335no text on the right side of the rectangle."
e037c34c Dave Love1999-08-23 14:28:34 +0000336 (interactive "*r\nP")
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000337 (apply-on-rectangle 'open-rectangle-line start end fill)
08ce70d1 Jim Blandy1992-11-16 01:40:15 +0000338 (goto-char start))
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000339
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000340(defun open-rectangle-line (startcol endcol fill)
b29b5c24 Richard M. Stallman2005-01-29 17:26:39 +0000341 (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
74be0ade
DL
Dave Love2000-07-18 12:50:38 +0000342 (unless (and (not fill)
343 (= (point) (point-at-eol)))
344 (indent-to endcol))))
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000345
06b60517 Juanma Barranquero2011-04-19 15:44:55 +0200346(defun delete-whitespace-rectangle-line (startcol _endcol fill)
b29b5c24 Richard M. Stallman2005-01-29 17:26:39 +0000347 (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000348 (unless (= (point) (point-at-eol))
a77540e7
JB
Johan Bockgård2015-04-12 15:50:02 +0200349 (delete-region (point) (progn (skip-syntax-forward " " (point-at-eol))
350 (point))))))
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000351
b3a4edce
MR
Markus Rost2002-05-07 19:30:21 +0000352;;;###autoload
353(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name
354
f9f9507e Jim Blandy1991-05-09 21:50:55 +0000355;;;###autoload
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000356(defun delete-whitespace-rectangle (start end &optional fill)
ecb079ed
RS
Richard M. Stallman1998-05-24 00:52:38 +0000357 "Delete all whitespace following a specified column in each line.
358The left edge of the rectangle specifies the position in each line
359at which whitespace deletion should begin. On each line in the
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000360rectangle, all continuous whitespace starting at that column is deleted.
ecb079ed Richard M. Stallman1998-05-24 00:52:38 +0000361
e037c34c Dave Love1999-08-23 14:28:34 +0000362When called from a program the rectangle's corners are START and END.
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000363With a prefix (or a FILL) argument, also fill too short lines."
e037c34c Dave Love1999-08-23 14:28:34 +0000364 (interactive "*r\nP")
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000365 (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill))
366
b9e81d0a Stefan Monnier2001-11-17 00:47:42 +0000367(defvar string-rectangle-history nil)
197615f3 Dave Love2000-11-22 17:33:21 +0000368(defun string-rectangle-line (startcol endcol string delete)
b9e81d0a Stefan Monnier2001-11-17 00:47:42 +0000369 (move-to-column startcol t)
197615f3
DL
Dave Love2000-11-22 17:33:21 +0000370 (if delete
371 (delete-rectangle-line startcol endcol nil))
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000372 (insert string))
131ca136 Eric S. Raymond1993-03-27 01:58:26 +0000373
5139e960
SM
Stefan Monnier2014-06-17 15:33:58 -0400374(defvar-local rectangle--string-preview-state nil)
375(defvar-local rectangle--string-preview-window nil)
376
377(defun rectangle--string-flush-preview ()
378 (mapc #'delete-overlay (nthcdr 3 rectangle--string-preview-state))
379 (setf (nthcdr 3 rectangle--string-preview-state) nil))
380
381(defun rectangle--string-erase-preview ()
382 (with-selected-window rectangle--string-preview-window
383 (rectangle--string-flush-preview)))
384
385(defun rectangle--space-to (col)
386 (propertize " " 'display `(space :align-to ,col)))
387
388(defface rectangle-preview-face '((t :inherit region))
389 "The face to use for the `string-rectangle' preview.")
390
391(defcustom rectangle-preview t
392 "If non-nil, `string-rectangle' will show an-the-fly preview."
393 :type 'boolean)
394
395(defun rectangle--string-preview ()
396 (let ((str (minibuffer-contents)))
397 (when (equal str "")
398 (setq str (or (car-safe minibuffer-default)
399 (if (stringp minibuffer-default) minibuffer-default))))
31ca1841 Stefan Monnier2014-07-18 21:43:29 -0400400 (when str (setq str (propertize str 'face 'region)))
5139e960
SM
Stefan Monnier2014-06-17 15:33:58 -0400401 (with-selected-window rectangle--string-preview-window
402 (unless (or (null rectangle--string-preview-state)
403 (equal str (car rectangle--string-preview-state)))
404 (rectangle--string-flush-preview)
405 (apply-on-rectangle
406 (lambda (startcol endcol)
407 (let* ((sc (move-to-column startcol))
408 (start (if (<= sc startcol) (point)
409 (forward-char -1)
410 (setq sc (current-column))
411 (point)))
412 (ec (move-to-column endcol))
413 (end (point))
414 (ol (make-overlay start end)))
415 (push ol (nthcdr 3 rectangle--string-preview-state))
416 ;; FIXME: The extra spacing doesn't interact correctly with
417 ;; the extra spacing added by the rectangular-region-highlight.
418 (when (< sc startcol)
419 (overlay-put ol 'before-string (rectangle--space-to startcol)))
420 (let ((as (when (< endcol ec)
421 ;; (rectangle--space-to ec)
422 (spaces-string (- ec endcol))
423 )))
424 (if (= start end)
425 (overlay-put ol 'after-string (if as (concat str as) str))
426 (overlay-put ol 'display str)
427 (if as (overlay-put ol 'after-string as))))))
428 (nth 1 rectangle--string-preview-state)
429 (nth 2 rectangle--string-preview-state))))))
430
431;; FIXME: Should this be turned into inhibit-region-highlight and made to apply
432;; to non-rectangular regions as well?
433(defvar rectangle--inhibit-region-highlight nil)
434
131ca136 Eric S. Raymond1993-03-27 01:58:26 +0000435;;;###autoload
35f901fa
GM
Gerd Moellmann2001-04-24 10:57:05 +0000436(defun string-rectangle (start end string)
437 "Replace rectangle contents with STRING on each line.
438The length of STRING need not be the same as the rectangle width.
439
440Called from a program, takes three args; START, END and STRING."
b9e81d0a Stefan Monnier2001-11-17 00:47:42 +0000441 (interactive
5139e960
SM
Stefan Monnier2014-06-17 15:33:58 -0400442 (progn
443 (make-local-variable 'rectangle--string-preview-state)
444 (make-local-variable 'rectangle--inhibit-region-highlight)
445 (let* ((buf (current-buffer))
446 (win (if (eq (window-buffer) buf) (selected-window)))
447 (start (region-beginning))
448 (end (region-end))
449 (rectangle--string-preview-state `(nil ,start ,end))
450 ;; Rectangle-region-highlighting doesn't work well in the presence
451 ;; of the preview overlays. We could work harder to try and make
452 ;; it work better, but it's easier to just disable it temporarily.
453 (rectangle--inhibit-region-highlight t))
454 (barf-if-buffer-read-only)
455 (list start end
456 (minibuffer-with-setup-hook
457 (lambda ()
458 (setq rectangle--string-preview-window win)
459 (add-hook 'minibuffer-exit-hook
460 #'rectangle--string-erase-preview nil t)
461 (add-hook 'post-command-hook
462 #'rectangle--string-preview nil t))
5b76833f Romain Francoise2005-09-24 13:44:02 +0000463 (read-string (format "String rectangle (default %s): "
b9e81d0a
SM
Stefan Monnier2001-11-17 00:47:42 +0000464 (or (car string-rectangle-history) ""))
465 nil 'string-rectangle-history
5139e960 Stefan Monnier2014-06-17 15:33:58 -0400466 (car string-rectangle-history)))))))
7509a874
LMI
Lars Magne Ingebrigtsen2011-07-14 17:23:08 +0200467 (goto-char
468 (apply-on-rectangle 'string-rectangle-line start end string t)))
852eeeaf Dave Love2000-03-09 22:50:30 +0000469
0c54cd99 Richard M. Stallman2002-03-28 18:26:36 +0000470;;;###autoload
35f901fa
GM
Gerd Moellmann2001-04-24 10:57:05 +0000471(defalias 'replace-rectangle 'string-rectangle)
472
473;;;###autoload
474(defun string-insert-rectangle (start end string)
475 "Insert STRING on each line of region-rectangle, shifting text right.
476
477When called from a program, the rectangle's corners are START and END.
478The left edge of the rectangle specifies the column for insertion.
479This command does not delete or overwrite any existing text."
b9e81d0a
SM
Stefan Monnier2001-11-17 00:47:42 +0000480 (interactive
481 (progn (barf-if-buffer-read-only)
482 (list
483 (region-beginning)
484 (region-end)
5b76833f Romain Francoise2005-09-24 13:44:02 +0000485 (read-string (format "String insert rectangle (default %s): "
b9e81d0a
SM
Stefan Monnier2001-11-17 00:47:42 +0000486 (or (car string-rectangle-history) ""))
487 nil 'string-rectangle-history
488 (car string-rectangle-history)))))
35f901fa
GM
Gerd Moellmann2001-04-24 10:57:05 +0000489 (apply-on-rectangle 'string-rectangle-line start end string nil))
490
852eeeaf Dave Love2000-03-09 22:50:30 +0000491;;;###autoload
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000492(defun clear-rectangle (start end &optional fill)
e037c34c
DL
Dave Love1999-08-23 14:28:34 +0000493 "Blank out the region-rectangle.
494The text previously in the region is overwritten with blanks.
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000495
e037c34c Dave Love1999-08-23 14:28:34 +0000496When called from a program the rectangle's corners are START and END.
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000497With a prefix (or a FILL) argument, also fill with blanks the parts of the
498rectangle which were empty."
e037c34c Dave Love1999-08-23 14:28:34 +0000499 (interactive "*r\nP")
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000500 (apply-on-rectangle 'clear-rectangle-line start end fill))
501
502(defun clear-rectangle-line (startcol endcol fill)
7dfee029 Richard M. Stallman2002-02-26 16:05:48 +0000503 (let ((pt (point-at-eol)))
b29b5c24 Richard M. Stallman2005-01-29 17:26:39 +0000504 (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
e417c66f
RS
Richard M. Stallman1999-08-03 18:36:16 +0000505 (if (and (not fill)
506 (<= (save-excursion (goto-char pt) (current-column)) endcol))
507 (delete-region (point) pt)
508 ;; else
509 (setq pt (point))
b9e81d0a Stefan Monnier2001-11-17 00:47:42 +0000510 (move-to-column endcol t)
7dfee029 Richard M. Stallman2002-02-26 16:05:48 +0000511 (setq endcol (current-column))
e417c66f Richard M. Stallman1999-08-03 18:36:16 +0000512 (delete-region pt (point))
7dfee029 Richard M. Stallman2002-02-26 16:05:48 +0000513 (indent-to endcol)))))
a2535589 Joseph Arceneaux1989-10-31 16:00:07 +0000514
99f053cf
JA
Jari Aalto2010-12-15 10:56:22 +0800515;; Line numbers for `rectangle-number-line-callback'.
516(defvar rectangle-number-line-counter)
517
06b60517 Juanma Barranquero2011-04-19 15:44:55 +0200518(defun rectangle-number-line-callback (start _end format-string)
99f053cf
JA
Jari Aalto2010-12-15 10:56:22 +0800519 (move-to-column start t)
520 (insert (format format-string rectangle-number-line-counter))
521 (setq rectangle-number-line-counter
522 (1+ rectangle-number-line-counter)))
523
44a651f0 Paul Eggert2014-08-03 23:27:14 -0700524(defun rectangle--default-line-number-format (start end start-at)
99f053cf
JA
Jari Aalto2010-12-15 10:56:22 +0800525 (concat "%"
526 (int-to-string (length (int-to-string (+ (count-lines start end)
527 start-at))))
528 "d "))
529
530;;;###autoload
531(defun rectangle-number-lines (start end start-at &optional format)
532 "Insert numbers in front of the region-rectangle.
533
534START-AT, if non-nil, should be a number from which to begin
535counting. FORMAT, if non-nil, should be a format string to pass
536to `format' along with the line count. When called interactively
537with a prefix argument, prompt for START-AT and FORMAT."
538 (interactive
539 (if current-prefix-arg
540 (let* ((start (region-beginning))
541 (end (region-end))
542 (start-at (read-number "Number to count from: " 1)))
543 (list start end start-at
544 (read-string "Format string: "
44a651f0 Paul Eggert2014-08-03 23:27:14 -0700545 (rectangle--default-line-number-format
99f053cf
JA
Jari Aalto2010-12-15 10:56:22 +0800546 start end start-at))))
547 (list (region-beginning) (region-end) 1 nil)))
548 (unless format
44a651f0 Paul Eggert2014-08-03 23:27:14 -0700549 (setq format (rectangle--default-line-number-format start end start-at)))
99f053cf
JA
Jari Aalto2010-12-15 10:56:22 +0800550 (let ((rectangle-number-line-counter start-at))
551 (apply-on-rectangle 'rectangle-number-line-callback
552 start end format)))
553
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400554;;; New rectangle integration with kill-ring.
555
7818df11 Stefan Monnier2013-11-11 00:18:53 -0500556;; FIXME: known problems with the new rectangle support:
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400557;; - lots of commands handle the region without paying attention to its
558;; rectangular shape.
559
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400560(add-function :around redisplay-highlight-region-function
561 #'rectangle--highlight-for-redisplay)
562(add-function :around redisplay-unhighlight-region-function
563 #'rectangle--unhighlight-for-redisplay)
564(add-function :around region-extract-function
565 #'rectangle--extract-region)
566
4aca7145
SM
Stefan Monnier2013-11-03 22:06:54 -0500567(defvar rectangle-mark-mode-map
568 (let ((map (make-sparse-keymap)))
569 (define-key map [?\C-o] 'open-rectangle)
570 (define-key map [?\C-t] 'string-rectangle)
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400571 (define-key map [remap exchange-point-and-mark]
572 'rectangle-exchange-point-and-mark)
573 (dolist (cmd '(right-char left-char forward-char backward-char
574 next-line previous-line))
575 (define-key map (vector 'remap cmd)
576 (intern (format "rectangle-%s" cmd))))
4aca7145
SM
Stefan Monnier2013-11-03 22:06:54 -0500577 map)
578 "Keymap used while marking a rectangular region.")
579
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400580;;;###autoload
4aca7145
SM
Stefan Monnier2013-11-03 22:06:54 -0500581(define-minor-mode rectangle-mark-mode
582 "Toggle the region as rectangular.
583Activates the region if needed. Only lasts until the region is deactivated."
584 nil nil nil
7e74ad02 Stefan Monnier2014-06-11 17:51:44 -0400585 (rectangle--reset-crutches)
4aca7145 Stefan Monnier2013-11-03 22:06:54 -0500586 (when rectangle-mark-mode
2013a2f9
SM
Stefan Monnier2013-12-15 21:24:08 -0500587 (add-hook 'deactivate-mark-hook
588 (lambda () (rectangle-mark-mode -1)))
02033d49 Stefan Monnier2013-12-08 02:32:01 -0500589 (unless (region-active-p)
56f5ea17 Kelly Dean2015-02-18 07:38:13 +0000590 (push-mark (point) t t)
d791cc3b Bastien Guerry2014-01-13 11:55:22 +0100591 (message "Mark set (rectangle mode)"))))
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400592
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400593(defun rectangle-exchange-point-and-mark (&optional arg)
594 "Like `exchange-point-and-mark' but cycles through the rectangle's corners."
595 (interactive "P")
596 (if arg
597 (progn
598 (setq this-command 'exchange-point-and-mark)
599 (exchange-point-and-mark arg))
600 (let* ((p (point))
601 (repeat (eq this-command last-command))
602 (m (mark))
603 (p<m (< p m))
604 (cols (if p<m (rectangle--pos-cols p m) (rectangle--pos-cols m p)))
605 (cp (if p<m (car cols) (cdr cols)))
606 (cm (if p<m (cdr cols) (car cols))))
607 (if repeat (setq this-command 'exchange-point-and-mark))
608 (rectangle--reset-crutches)
609 (goto-char p)
610 (rectangle--col-pos (if repeat cm cp) 'mark)
611 (set-mark (point))
612 (goto-char m)
613 (rectangle--col-pos (if repeat cp cm) 'point))))
614
615(defun rectangle--*-char (cmd n &optional other-cmd)
616 ;; Part of the complexity here is that I'm trying to avoid making assumptions
617 ;; about the L2R/R2L direction of text around point, but this is largely
618 ;; useless since the rectangles implemented in this file are "logical
619 ;; rectangles" and not "visual rectangles", so in the presence of
620 ;; bidirectional text things won't work well anyway.
621 (if (< n 0) (rectangle--*-char other-cmd (- n))
622 (let ((col (rectangle--point-col (point))))
623 (while (> n 0)
624 (let* ((bol (line-beginning-position))
625 (eol (line-end-position))
626 (curcol (current-column))
627 (nextcol
628 (condition-case nil
629 (save-excursion
630 (funcall cmd 1)
631 (cond
632 ((> bol (point)) (- curcol 1))
633 ((< eol (point)) (+ col (1+ n)))
634 (t (current-column))))
635 (end-of-buffer (+ col (1+ n)))
636 (beginning-of-buffer (- curcol 1))))
637 (diff (abs (- nextcol col))))
638 (cond
639 ((and (< nextcol curcol) (< curcol col))
640 (let ((curdiff (- col curcol)))
641 (if (<= curdiff n)
642 (progn (cl-decf n curdiff) (setq col curcol))
643 (setq col (- col n) n 0))))
644 ((< nextcol 0) (ding) (setq n 0 col 0)) ;Bumping into BOL!
645 ((= nextcol curcol) (funcall cmd 1))
646 (t ;; (> nextcol curcol)
647 (if (<= diff n)
648 (progn (cl-decf n diff) (setq col nextcol))
649 (setq col (if (< col nextcol) (+ col n) (- col n)) n 0))))))
650 ;; FIXME: This rectangle--col-pos's move-to-column is wasted!
651 (rectangle--col-pos col 'point))))
652
653(defun rectangle-right-char (&optional n)
654 "Like `right-char' but steps into wide chars and moves past EOL."
655 (interactive "p") (rectangle--*-char #'right-char n #'left-char))
656(defun rectangle-left-char (&optional n)
657 "Like `left-char' but steps into wide chars and moves past EOL."
658 (interactive "p") (rectangle--*-char #'left-char n #'right-char))
659
660(defun rectangle-forward-char (&optional n)
661 "Like `forward-char' but steps into wide chars and moves past EOL."
662 (interactive "p") (rectangle--*-char #'forward-char n #'backward-char))
663(defun rectangle-backward-char (&optional n)
664 "Like `backward-char' but steps into wide chars and moves past EOL."
665 (interactive "p") (rectangle--*-char #'backward-char n #'forward-char))
666
667(defun rectangle-next-line (&optional n)
668 "Like `next-line' but steps into wide chars and moves past EOL.
669Ignores `line-move-visual'."
670 (interactive "p")
671 (let ((col (rectangle--point-col (point))))
672 (forward-line n)
673 (rectangle--col-pos col 'point)))
674(defun rectangle-previous-line (&optional n)
675 "Like `previous-line' but steps into wide chars and moves past EOL.
676Ignores `line-move-visual'."
677 (interactive "p")
678 (let ((col (rectangle--point-col (point))))
679 (forward-line (- n))
680 (rectangle--col-pos col 'point)))
681
682
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400683(defun rectangle--extract-region (orig &optional delete)
4aca7145 Stefan Monnier2013-11-03 22:06:54 -0500684 (if (not rectangle-mark-mode)
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400685 (funcall orig delete)
686 (let* ((strs (funcall (if delete
687 #'delete-extract-rectangle
688 #'extract-rectangle)
689 (region-beginning) (region-end)))
690 (str (mapconcat #'identity strs "\n")))
691 (when (eq last-command 'kill-region)
692 ;; Try to prevent kill-region from appending this to some
693 ;; earlier element.
694 (setq last-command 'kill-region-dont-append))
695 (when strs
696 (put-text-property 0 (length str) 'yank-handler
697 `(rectangle--insert-for-yank ,strs t)
698 str)
699 str))))
700
701(defun rectangle--insert-for-yank (strs)
702 (push (point) buffer-undo-list)
703 (let ((undo-at-start buffer-undo-list))
704 (insert-rectangle strs)
705 (setq yank-undo-function
706 (lambda (_start _end)
707 (undo-start)
708 (setcar undo-at-start nil) ;Turn it into a boundary.
709 (while (not (eq pending-undo-list (cdr undo-at-start)))
710 (undo-more 1))))))
711
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400712(defun rectangle--place-cursor (leftcol left str)
713 (let ((pc (window-parameter nil 'rectangle--point-crutches)))
714 (if (and (eq left (car pc)) (eq leftcol (cdr pc)))
715 (put-text-property 0 1 'cursor 1 str))))
716
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400717(defun rectangle--highlight-for-redisplay (orig start end window rol)
718 (cond
4aca7145 Stefan Monnier2013-11-03 22:06:54 -0500719 ((not rectangle-mark-mode)
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400720 (funcall orig start end window rol))
5139e960 Stefan Monnier2014-06-17 15:33:58 -0400721 (rectangle--inhibit-region-highlight
9362232c Stefan Monnier2014-07-03 18:22:42 -0400722 (funcall redisplay-unhighlight-region-function rol)
5139e960 Stefan Monnier2014-06-17 15:33:58 -0400723 nil)
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400724 ((and (eq 'rectangle (car-safe rol))
a0d5f7a4 Stefan Monnier2013-11-04 15:45:36 -0500725 (eq (nth 1 rol) (buffer-chars-modified-tick))
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400726 (eq start (nth 2 rol))
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400727 (eq end (nth 3 rol))
728 (equal (rectangle--crutches) (nth 4 rol)))
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400729 rol)
730 (t
731 (save-excursion
732 (let* ((nrol nil)
733 (old (if (eq 'rectangle (car-safe rol))
7e74ad02 Stefan Monnier2014-06-11 17:51:44 -0400734 (nthcdr 5 rol)
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400735 (funcall redisplay-unhighlight-region-function rol)
7e74ad02 Stefan Monnier2014-06-11 17:51:44 -0400736 nil)))
5139e960
SM
Stefan Monnier2014-06-17 15:33:58 -0400737 (cl-assert (eq (window-buffer window) (current-buffer)))
738 ;; `rectangle--pos-cols' looks up the `selected-window's parameter!
739 (with-selected-window window
740 (apply-on-rectangle
741 (lambda (leftcol rightcol)
742 (let* ((mleft (move-to-column leftcol))
743 (left (point))
744 ;; BEWARE: In the presence of other overlays with
745 ;; before/after/display-strings, this happens to move to
746 ;; the column "as if the overlays were not applied", which
747 ;; is sometimes what we want, tho it can be
748 ;; considered a bug in move-to-column (it should arguably
749 ;; pay attention to the before/after-string/display
750 ;; properties when computing the column).
751 (mright (move-to-column rightcol))
752 (right (point))
753 (ol
754 (if (not old)
755 (let ((ol (make-overlay left right)))
756 (overlay-put ol 'window window)
757 (overlay-put ol 'face 'region)
758 ol)
759 (let ((ol (pop old)))
760 (move-overlay ol left right (current-buffer))
761 ol))))
762 ;; `move-to-column' may stop before the column (if bumping into
763 ;; EOL) or overshoot it a little, when column is in the middle
764 ;; of a char.
765 (cond
766 ((< mleft leftcol) ;`leftcol' is past EOL.
767 (overlay-put ol 'before-string (rectangle--space-to leftcol))
768 (setq mright (max mright leftcol)))
769 ((and (> mleft leftcol) ;`leftcol' is in the middle of a char.
770 (eq (char-before left) ?\t))
771 (setq left (1- left))
772 (move-overlay ol left right)
773 (goto-char left)
774 (overlay-put ol 'before-string (rectangle--space-to leftcol)))
775 ((overlay-get ol 'before-string)
776 (overlay-put ol 'before-string nil)))
777 (cond
778 ;; While doing rectangle--string-preview, the two sets of
779 ;; overlays steps on the other's toes. I fixed some of the
780 ;; problems, but others remain. The main one is the two
781 ;; (rectangle--space-to rightcol) below which try to virtually
782 ;; insert missing text, but during "preview", the text is not
783 ;; missing (it's provided by preview's own overlay).
784 (rectangle--string-preview-state
785 (if (overlay-get ol 'after-string)
786 (overlay-put ol 'after-string nil)))
787 ((< mright rightcol) ;`rightcol' is past EOL.
788 (let ((str (rectangle--space-to rightcol)))
7e74ad02 Stefan Monnier2014-06-11 17:51:44 -0400789 (put-text-property 0 (length str) 'face 'region str)
5139e960
SM
Stefan Monnier2014-06-17 15:33:58 -0400790 ;; If cursor happens to be here, draw it at the right place.
791 (rectangle--place-cursor leftcol left str)
792 (overlay-put ol 'after-string str)))
793 ((and (> mright rightcol) ;`rightcol's in the middle of a char.
794 (eq (char-before right) ?\t))
795 (setq right (1- right))
796 (move-overlay ol left right)
797 (if (= rightcol leftcol)
798 (overlay-put ol 'after-string nil)
799 (goto-char right)
800 (let ((str (rectangle--space-to rightcol)))
801 (put-text-property 0 (length str) 'face 'region str)
802 (when (= left right)
803 (rectangle--place-cursor leftcol left str))
804 (overlay-put ol 'after-string str))))
805 ((overlay-get ol 'after-string)
806 (overlay-put ol 'after-string nil)))
807 (when (and (= leftcol rightcol) (display-graphic-p))
808 ;; Make zero-width rectangles visible!
809 (overlay-put ol 'after-string
810 (concat (propertize " "
811 'face '(region (:height 0.2)))
812 (overlay-get ol 'after-string))))
813 (push ol nrol)))
814 start end))
3472b6c6 Stefan Monnier2013-10-29 12:11:50 -0400815 (mapc #'delete-overlay old)
7e74ad02
SM
Stefan Monnier2014-06-11 17:51:44 -0400816 `(rectangle ,(buffer-chars-modified-tick)
817 ,start ,end ,(rectangle--crutches)
818 ,@nrol))))))
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400819
820(defun rectangle--unhighlight-for-redisplay (orig rol)
821 (if (not (eq 'rectangle (car-safe rol)))
822 (funcall orig rol)
7e74ad02 Stefan Monnier2014-06-11 17:51:44 -0400823 (mapc #'delete-overlay (nthcdr 5 rol))
3472b6c6
SM
Stefan Monnier2013-10-29 12:11:50 -0400824 (setcar (cdr rol) nil)))
825
08ce70d1 Jim Blandy1992-11-16 01:40:15 +0000826(provide 'rect)
6594deb0
ER
Eric S. Raymond1992-05-30 22:12:04 +0000827
828;;; rect.el ends here