Commit | Line | Data |
---|---|---|
3472b6c6 | 1 | ;;; rect.el --- rectangle functions for GNU Emacs -*- lexical-binding:t -*- |
6594deb0 | 2 | |
ab422c4d | 3 | ;; Copyright (C) 1985, 1999-2013 Free Software Foundation, Inc. |
9750e079 | 4 | |
aa01bed1 | 5 | ;; Maintainer: Didier Verna <didier@xemacs.org> |
d7b4d18f | 6 | ;; Keywords: internal |
bd78fa1d | 7 | ;; Package: emacs |
4821e2af | 8 | |
a2535589 JA |
9 | ;; This file is part of GNU Emacs. |
10 | ||
eb3fa2cf | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
a2535589 | 12 | ;; it under the terms of the GNU General Public License as published by |
eb3fa2cf GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
a2535589 JA |
15 | |
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 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
a2535589 | 23 | |
edbd2f74 ER |
24 | ;;; Commentary: |
25 | ||
e037c34c | 26 | ;; This package provides the operations on rectangles that are documented |
edbd2f74 ER |
27 | ;; in the Emacs manual. |
28 | ||
5614fd56 CY |
29 | ;; ### NOTE: this file was almost completely rewritten by Didier Verna |
30 | ;; <didier@xemacs.org> in July 1999. | |
e417c66f | 31 | |
4821e2af | 32 | ;;; Code: |
a2535589 | 33 | |
5614fd56 | 34 | ;; FIXME: this function should be replaced by `apply-on-rectangle' |
a2535589 JA |
35 | (defun operate-on-rectangle (function start end coerce-tabs) |
36 | "Call FUNCTION for each line of rectangle with corners at START, END. | |
37 | If COERCE-TABS is non-nil, convert multi-column characters | |
38 | that span the starting or ending columns on any line | |
39 | to multiple spaces before calling FUNCTION. | |
40 | FUNCTION is called with three arguments: | |
41 | position of start of segment of this line within the rectangle, | |
42 | number of columns that belong to rectangle but are before that position, | |
43 | number of columns that belong to rectangle but are after point. | |
44 | Point is at the end of the segment of this line within the rectangle." | |
45 | (let (startcol startlinepos endcol endlinepos) | |
46 | (save-excursion | |
47 | (goto-char start) | |
48 | (setq startcol (current-column)) | |
49 | (beginning-of-line) | |
50 | (setq startlinepos (point))) | |
51 | (save-excursion | |
52 | (goto-char end) | |
53 | (setq endcol (current-column)) | |
54 | (forward-line 1) | |
55 | (setq endlinepos (point-marker))) | |
56 | (if (< endcol startcol) | |
08ce70d1 | 57 | (setq startcol (prog1 endcol (setq endcol startcol)))) |
bc8ea543 RS |
58 | (save-excursion |
59 | (goto-char startlinepos) | |
60 | (while (< (point) endlinepos) | |
61 | (let (startpos begextra endextra) | |
e40261d0 | 62 | (if coerce-tabs |
b9e81d0a | 63 | (move-to-column startcol t) |
e40261d0 | 64 | (move-to-column startcol)) |
bc8ea543 RS |
65 | (setq begextra (- (current-column) startcol)) |
66 | (setq startpos (point)) | |
e40261d0 | 67 | (if coerce-tabs |
b9e81d0a | 68 | (move-to-column endcol t) |
e40261d0 | 69 | (move-to-column endcol)) |
daabd795 RS |
70 | ;; If we overshot, move back one character |
71 | ;; so that endextra will be positive. | |
72 | (if (and (not coerce-tabs) (> (current-column) endcol)) | |
73 | (backward-char 1)) | |
bc8ea543 RS |
74 | (setq endextra (- endcol (current-column))) |
75 | (if (< begextra 0) | |
76 | (setq endextra (+ endextra begextra) | |
77 | begextra 0)) | |
78 | (funcall function startpos begextra endextra)) | |
79 | (forward-line 1))) | |
a2535589 JA |
80 | (- endcol startcol))) |
81 | ||
e417c66f RS |
82 | (defun apply-on-rectangle (function start end &rest args) |
83 | "Call FUNCTION for each line of rectangle with corners at START, END. | |
84 | FUNCTION is called with two arguments: the start and end columns of the | |
e037c34c | 85 | rectangle, plus ARGS extra arguments. Point is at the beginning of line when |
7509a874 LMI |
86 | the function is called. |
87 | The final point after the last operation will be returned." | |
88 | (let (startcol startpt endcol endpt final-point) | |
e417c66f RS |
89 | (save-excursion |
90 | (goto-char start) | |
91 | (setq startcol (current-column)) | |
92 | (beginning-of-line) | |
93 | (setq startpt (point)) | |
94 | (goto-char end) | |
95 | (setq endcol (current-column)) | |
96 | (forward-line 1) | |
97 | (setq endpt (point-marker)) | |
98 | ;; ensure the start column is the left one. | |
99 | (if (< endcol startcol) | |
100 | (let ((col startcol)) | |
101 | (setq startcol endcol endcol col))) | |
102 | ;; start looping over lines | |
103 | (goto-char startpt) | |
104 | (while (< (point) endpt) | |
105 | (apply function startcol endcol args) | |
7509a874 | 106 | (setq final-point (point)) |
e417c66f | 107 | (forward-line 1))) |
7509a874 | 108 | final-point)) |
e417c66f RS |
109 | |
110 | (defun delete-rectangle-line (startcol endcol fill) | |
b29b5c24 | 111 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
b9e81d0a SM |
112 | (delete-region (point) |
113 | (progn (move-to-column endcol 'coerce) | |
114 | (point))))) | |
e417c66f RS |
115 | |
116 | (defun delete-extract-rectangle-line (startcol endcol lines fill) | |
117 | (let ((pt (point-at-eol))) | |
b29b5c24 | 118 | (if (< (move-to-column startcol (if fill t 'coerce)) startcol) |
e417c66f RS |
119 | (setcdr lines (cons (spaces-string (- endcol startcol)) |
120 | (cdr lines))) | |
121 | ;; else | |
122 | (setq pt (point)) | |
b9e81d0a | 123 | (move-to-column endcol t) |
5c831ccd | 124 | (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines)))) |
e417c66f RS |
125 | )) |
126 | ||
5614fd56 CY |
127 | ;; This is actually the only function that needs to do complicated |
128 | ;; stuff like what's happening in `operate-on-rectangle', because the | |
129 | ;; buffer might be read-only. | |
e417c66f RS |
130 | (defun extract-rectangle-line (startcol endcol lines) |
131 | (let (start end begextra endextra line) | |
132 | (move-to-column startcol) | |
133 | (setq start (point) | |
134 | begextra (- (current-column) startcol)) | |
135 | (move-to-column endcol) | |
136 | (setq end (point) | |
137 | endextra (- endcol (current-column))) | |
138 | (setq line (buffer-substring start (point))) | |
139 | (if (< begextra 0) | |
140 | (setq endextra (+ endextra begextra) | |
141 | begextra 0)) | |
142 | (if (< endextra 0) | |
143 | (setq endextra 0)) | |
144 | (goto-char start) | |
a2535589 JA |
145 | (while (search-forward "\t" end t) |
146 | (let ((width (- (current-column) | |
147 | (save-excursion (forward-char -1) | |
148 | (current-column))))) | |
149 | (setq line (concat (substring line 0 (- (point) end 1)) | |
150 | (spaces-string width) | |
e417c66f RS |
151 | (substring line (+ (length line) |
152 | (- (point) end))))))) | |
a2535589 JA |
153 | (if (or (> begextra 0) (> endextra 0)) |
154 | (setq line (concat (spaces-string begextra) | |
155 | line | |
156 | (spaces-string endextra)))) | |
e417c66f | 157 | (setcdr lines (cons line (cdr lines))))) |
a2535589 JA |
158 | |
159 | (defconst spaces-strings | |
160 | '["" " " " " " " " " " " " " " " " "]) | |
161 | ||
162 | (defun spaces-string (n) | |
6cda144f | 163 | "Return a string with N spaces." |
a2535589 | 164 | (if (<= n 8) (aref spaces-strings n) |
6cda144f | 165 | (make-string n ?\s))) |
f1180544 | 166 | |
f9f9507e | 167 | ;;;###autoload |
e417c66f | 168 | (defun delete-rectangle (start end &optional fill) |
e037c34c DL |
169 | "Delete (don't save) text in the region-rectangle. |
170 | The same range of columns is deleted in each line starting with the | |
171 | line where the region begins and ending with the line where the region | |
172 | ends. | |
173 | ||
174 | When called from a program the rectangle's corners are START and END. | |
175 | With a prefix (or a FILL) argument, also fill lines where nothing has | |
176 | to be deleted." | |
177 | (interactive "*r\nP") | |
e417c66f | 178 | (apply-on-rectangle 'delete-rectangle-line start end fill)) |
a2535589 | 179 | |
f9f9507e | 180 | ;;;###autoload |
e417c66f | 181 | (defun delete-extract-rectangle (start end &optional fill) |
7db6139a | 182 | "Delete the contents of the rectangle with corners at START and END. |
e037c34c | 183 | Return it as a list of strings, one for each line of the rectangle. |
e417c66f | 184 | |
e037c34c | 185 | When called from a program the rectangle's corners are START and END. |
e417c66f RS |
186 | With an optional FILL argument, also fill lines where nothing has to be |
187 | deleted." | |
188 | (let ((lines (list nil))) | |
189 | (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill) | |
190 | (nreverse (cdr lines)))) | |
a2535589 | 191 | |
f9f9507e | 192 | ;;;###autoload |
a2535589 | 193 | (defun extract-rectangle (start end) |
e037c34c DL |
194 | "Return the contents of the rectangle with corners at START and END. |
195 | Return it as a list of strings, one for each line of the rectangle." | |
e417c66f RS |
196 | (let ((lines (list nil))) |
197 | (apply-on-rectangle 'extract-rectangle-line start end lines) | |
198 | (nreverse (cdr lines)))) | |
a2535589 JA |
199 | |
200 | (defvar killed-rectangle nil | |
e037c34c | 201 | "Rectangle for `yank-rectangle' to insert.") |
a2535589 | 202 | |
f9f9507e | 203 | ;;;###autoload |
e417c66f | 204 | (defun kill-rectangle (start end &optional fill) |
e037c34c DL |
205 | "Delete the region-rectangle and save it as the last killed one. |
206 | ||
207 | When called from a program the rectangle's corners are START and END. | |
208 | You might prefer to use `delete-extract-rectangle' from a program. | |
e417c66f RS |
209 | |
210 | With a prefix (or a FILL) argument, also fill lines where nothing has to be | |
5c831ccd EZ |
211 | deleted. |
212 | ||
213 | If the buffer is read-only, Emacs will beep and refrain from deleting | |
214 | the rectangle, but put it in the kill ring anyway. This means that | |
215 | you can use this command to copy text from a read-only buffer. | |
216 | \(If the variable `kill-read-only-ok' is non-nil, then this won't | |
217 | even beep.)" | |
218 | (interactive "r\nP") | |
219 | (condition-case nil | |
220 | (setq killed-rectangle (delete-extract-rectangle start end fill)) | |
221 | ((buffer-read-only text-read-only) | |
2549c068 | 222 | (setq deactivate-mark t) |
5c831ccd EZ |
223 | (setq killed-rectangle (extract-rectangle start end)) |
224 | (if kill-read-only-ok | |
225 | (progn (message "Read only text copied to kill ring") nil) | |
226 | (barf-if-buffer-read-only) | |
227 | (signal 'text-read-only (list (current-buffer))))))) | |
e417c66f | 228 | |
be755c79 RT |
229 | ;;;###autoload |
230 | (defun copy-rectangle-as-kill (start end) | |
231 | "Copy the region-rectangle and save it as the last killed one." | |
232 | (interactive "r") | |
233 | (setq killed-rectangle (extract-rectangle start end)) | |
2549c068 CY |
234 | (setq deactivate-mark t) |
235 | (if (called-interactively-p 'interactive) | |
236 | (indicate-copied-region (length (car killed-rectangle))))) | |
be755c79 | 237 | |
f9f9507e | 238 | ;;;###autoload |
a2535589 JA |
239 | (defun yank-rectangle () |
240 | "Yank the last killed rectangle with upper left corner at point." | |
e037c34c | 241 | (interactive "*") |
a2535589 JA |
242 | (insert-rectangle killed-rectangle)) |
243 | ||
f9f9507e | 244 | ;;;###autoload |
a2535589 JA |
245 | (defun insert-rectangle (rectangle) |
246 | "Insert text of RECTANGLE with upper left corner at point. | |
573f9b32 RS |
247 | RECTANGLE's first line is inserted at point, its second |
248 | line is inserted at a point vertically under point, etc. | |
23317eac RS |
249 | RECTANGLE should be a list of strings. |
250 | After this command, the mark is at the upper left corner | |
251 | and point is at the lower right corner." | |
a2535589 JA |
252 | (let ((lines rectangle) |
253 | (insertcolumn (current-column)) | |
254 | (first t)) | |
23317eac | 255 | (push-mark) |
a2535589 JA |
256 | (while lines |
257 | (or first | |
258 | (progn | |
259 | (forward-line 1) | |
260 | (or (bolp) (insert ?\n)) | |
b9e81d0a | 261 | (move-to-column insertcolumn t))) |
a2535589 | 262 | (setq first nil) |
afa0467f | 263 | (insert-for-yank (car lines)) |
a2535589 JA |
264 | (setq lines (cdr lines))))) |
265 | ||
f9f9507e | 266 | ;;;###autoload |
e417c66f | 267 | (defun open-rectangle (start end &optional fill) |
e037c34c DL |
268 | "Blank out the region-rectangle, shifting text right. |
269 | ||
270 | The text previously in the region is not overwritten by the blanks, | |
271 | but instead winds up to the right of the rectangle. | |
e417c66f | 272 | |
e037c34c | 273 | When called from a program the rectangle's corners are START and END. |
6cda144f JB |
274 | With a prefix (or a FILL) argument, fill with blanks even if there is |
275 | no text on the right side of the rectangle." | |
e037c34c | 276 | (interactive "*r\nP") |
e417c66f | 277 | (apply-on-rectangle 'open-rectangle-line start end fill) |
08ce70d1 | 278 | (goto-char start)) |
a2535589 | 279 | |
e417c66f | 280 | (defun open-rectangle-line (startcol endcol fill) |
b29b5c24 | 281 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
74be0ade DL |
282 | (unless (and (not fill) |
283 | (= (point) (point-at-eol))) | |
284 | (indent-to endcol)))) | |
e417c66f | 285 | |
06b60517 | 286 | (defun delete-whitespace-rectangle-line (startcol _endcol fill) |
b29b5c24 | 287 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
e417c66f | 288 | (unless (= (point) (point-at-eol)) |
35f901fa | 289 | (delete-region (point) (progn (skip-syntax-forward " ") (point)))))) |
a2535589 | 290 | |
b3a4edce MR |
291 | ;;;###autoload |
292 | (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name | |
293 | ||
ecb079ed | 294 | ;;;###autoload |
e417c66f | 295 | (defun delete-whitespace-rectangle (start end &optional fill) |
ecb079ed RS |
296 | "Delete all whitespace following a specified column in each line. |
297 | The left edge of the rectangle specifies the position in each line | |
298 | at which whitespace deletion should begin. On each line in the | |
e417c66f | 299 | rectangle, all continuous whitespace starting at that column is deleted. |
ecb079ed | 300 | |
e037c34c | 301 | When called from a program the rectangle's corners are START and END. |
e417c66f | 302 | With a prefix (or a FILL) argument, also fill too short lines." |
e037c34c | 303 | (interactive "*r\nP") |
e417c66f RS |
304 | (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill)) |
305 | ||
b9e81d0a | 306 | (defvar string-rectangle-history nil) |
197615f3 | 307 | (defun string-rectangle-line (startcol endcol string delete) |
b9e81d0a | 308 | (move-to-column startcol t) |
197615f3 DL |
309 | (if delete |
310 | (delete-rectangle-line startcol endcol nil)) | |
e417c66f | 311 | (insert string)) |
131ca136 | 312 | |
852eeeaf | 313 | ;;;###autoload |
35f901fa GM |
314 | (defun string-rectangle (start end string) |
315 | "Replace rectangle contents with STRING on each line. | |
316 | The length of STRING need not be the same as the rectangle width. | |
317 | ||
318 | Called from a program, takes three args; START, END and STRING." | |
b9e81d0a SM |
319 | (interactive |
320 | (progn (barf-if-buffer-read-only) | |
321 | (list | |
322 | (region-beginning) | |
323 | (region-end) | |
5b76833f | 324 | (read-string (format "String rectangle (default %s): " |
b9e81d0a SM |
325 | (or (car string-rectangle-history) "")) |
326 | nil 'string-rectangle-history | |
327 | (car string-rectangle-history))))) | |
7509a874 LMI |
328 | (goto-char |
329 | (apply-on-rectangle 'string-rectangle-line start end string t))) | |
852eeeaf | 330 | |
0c54cd99 | 331 | ;;;###autoload |
35f901fa GM |
332 | (defalias 'replace-rectangle 'string-rectangle) |
333 | ||
334 | ;;;###autoload | |
335 | (defun string-insert-rectangle (start end string) | |
336 | "Insert STRING on each line of region-rectangle, shifting text right. | |
337 | ||
338 | When called from a program, the rectangle's corners are START and END. | |
339 | The left edge of the rectangle specifies the column for insertion. | |
340 | This command does not delete or overwrite any existing text." | |
b9e81d0a SM |
341 | (interactive |
342 | (progn (barf-if-buffer-read-only) | |
343 | (list | |
344 | (region-beginning) | |
345 | (region-end) | |
5b76833f | 346 | (read-string (format "String insert rectangle (default %s): " |
b9e81d0a SM |
347 | (or (car string-rectangle-history) "")) |
348 | nil 'string-rectangle-history | |
349 | (car string-rectangle-history))))) | |
35f901fa GM |
350 | (apply-on-rectangle 'string-rectangle-line start end string nil)) |
351 | ||
f9f9507e | 352 | ;;;###autoload |
e417c66f | 353 | (defun clear-rectangle (start end &optional fill) |
e037c34c DL |
354 | "Blank out the region-rectangle. |
355 | The text previously in the region is overwritten with blanks. | |
e417c66f | 356 | |
e037c34c | 357 | When called from a program the rectangle's corners are START and END. |
e417c66f RS |
358 | With a prefix (or a FILL) argument, also fill with blanks the parts of the |
359 | rectangle which were empty." | |
e037c34c | 360 | (interactive "*r\nP") |
e417c66f RS |
361 | (apply-on-rectangle 'clear-rectangle-line start end fill)) |
362 | ||
363 | (defun clear-rectangle-line (startcol endcol fill) | |
7dfee029 | 364 | (let ((pt (point-at-eol))) |
b29b5c24 | 365 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
e417c66f RS |
366 | (if (and (not fill) |
367 | (<= (save-excursion (goto-char pt) (current-column)) endcol)) | |
368 | (delete-region (point) pt) | |
369 | ;; else | |
370 | (setq pt (point)) | |
b9e81d0a | 371 | (move-to-column endcol t) |
7dfee029 | 372 | (setq endcol (current-column)) |
e417c66f | 373 | (delete-region pt (point)) |
7dfee029 | 374 | (indent-to endcol))))) |
a2535589 | 375 | |
99f053cf JA |
376 | ;; Line numbers for `rectangle-number-line-callback'. |
377 | (defvar rectangle-number-line-counter) | |
378 | ||
06b60517 | 379 | (defun rectangle-number-line-callback (start _end format-string) |
99f053cf JA |
380 | (move-to-column start t) |
381 | (insert (format format-string rectangle-number-line-counter)) | |
382 | (setq rectangle-number-line-counter | |
383 | (1+ rectangle-number-line-counter))) | |
384 | ||
385 | (defun rectange--default-line-number-format (start end start-at) | |
386 | (concat "%" | |
387 | (int-to-string (length (int-to-string (+ (count-lines start end) | |
388 | start-at)))) | |
389 | "d ")) | |
390 | ||
391 | ;;;###autoload | |
392 | (defun rectangle-number-lines (start end start-at &optional format) | |
393 | "Insert numbers in front of the region-rectangle. | |
394 | ||
395 | START-AT, if non-nil, should be a number from which to begin | |
396 | counting. FORMAT, if non-nil, should be a format string to pass | |
397 | to `format' along with the line count. When called interactively | |
398 | with a prefix argument, prompt for START-AT and FORMAT." | |
399 | (interactive | |
400 | (if current-prefix-arg | |
401 | (let* ((start (region-beginning)) | |
402 | (end (region-end)) | |
403 | (start-at (read-number "Number to count from: " 1))) | |
404 | (list start end start-at | |
405 | (read-string "Format string: " | |
406 | (rectange--default-line-number-format | |
407 | start end start-at)))) | |
408 | (list (region-beginning) (region-end) 1 nil))) | |
409 | (unless format | |
410 | (setq format (rectange--default-line-number-format start end start-at))) | |
411 | (let ((rectangle-number-line-counter start-at)) | |
412 | (apply-on-rectangle 'rectangle-number-line-callback | |
413 | start end format))) | |
414 | ||
3472b6c6 SM |
415 | ;;; New rectangle integration with kill-ring. |
416 | ||
7818df11 | 417 | ;; FIXME: known problems with the new rectangle support: |
3472b6c6 SM |
418 | ;; - lots of commands handle the region without paying attention to its |
419 | ;; rectangular shape. | |
420 | ||
3472b6c6 | 421 | (add-hook 'deactivate-mark-hook |
4aca7145 | 422 | (lambda () (rectangle-mark-mode -1))) |
3472b6c6 SM |
423 | |
424 | (add-function :around redisplay-highlight-region-function | |
425 | #'rectangle--highlight-for-redisplay) | |
426 | (add-function :around redisplay-unhighlight-region-function | |
427 | #'rectangle--unhighlight-for-redisplay) | |
428 | (add-function :around region-extract-function | |
429 | #'rectangle--extract-region) | |
430 | ||
4aca7145 SM |
431 | (defvar rectangle-mark-mode-map |
432 | (let ((map (make-sparse-keymap))) | |
433 | (define-key map [?\C-o] 'open-rectangle) | |
434 | (define-key map [?\C-t] 'string-rectangle) | |
435 | ;; (define-key map [remap open-line] 'open-rectangle) | |
436 | ;; (define-key map [remap transpose-chars] 'string-rectangle) | |
437 | map) | |
438 | "Keymap used while marking a rectangular region.") | |
439 | ||
3472b6c6 | 440 | ;;;###autoload |
4aca7145 SM |
441 | (define-minor-mode rectangle-mark-mode |
442 | "Toggle the region as rectangular. | |
443 | Activates the region if needed. Only lasts until the region is deactivated." | |
444 | nil nil nil | |
445 | (when rectangle-mark-mode | |
446 | (unless (region-active-p) (push-mark-command t)))) | |
3472b6c6 SM |
447 | |
448 | (defun rectangle--extract-region (orig &optional delete) | |
4aca7145 | 449 | (if (not rectangle-mark-mode) |
3472b6c6 SM |
450 | (funcall orig delete) |
451 | (let* ((strs (funcall (if delete | |
452 | #'delete-extract-rectangle | |
453 | #'extract-rectangle) | |
454 | (region-beginning) (region-end))) | |
455 | (str (mapconcat #'identity strs "\n"))) | |
456 | (when (eq last-command 'kill-region) | |
457 | ;; Try to prevent kill-region from appending this to some | |
458 | ;; earlier element. | |
459 | (setq last-command 'kill-region-dont-append)) | |
460 | (when strs | |
461 | (put-text-property 0 (length str) 'yank-handler | |
462 | `(rectangle--insert-for-yank ,strs t) | |
463 | str) | |
464 | str)))) | |
465 | ||
466 | (defun rectangle--insert-for-yank (strs) | |
467 | (push (point) buffer-undo-list) | |
468 | (let ((undo-at-start buffer-undo-list)) | |
469 | (insert-rectangle strs) | |
470 | (setq yank-undo-function | |
471 | (lambda (_start _end) | |
472 | (undo-start) | |
473 | (setcar undo-at-start nil) ;Turn it into a boundary. | |
474 | (while (not (eq pending-undo-list (cdr undo-at-start))) | |
475 | (undo-more 1)))))) | |
476 | ||
477 | (defun rectangle--highlight-for-redisplay (orig start end window rol) | |
478 | (cond | |
4aca7145 | 479 | ((not rectangle-mark-mode) |
3472b6c6 SM |
480 | (funcall orig start end window rol)) |
481 | ((and (eq 'rectangle (car-safe rol)) | |
a0d5f7a4 | 482 | (eq (nth 1 rol) (buffer-chars-modified-tick)) |
3472b6c6 SM |
483 | (eq start (nth 2 rol)) |
484 | (eq end (nth 3 rol))) | |
485 | rol) | |
486 | (t | |
487 | (save-excursion | |
488 | (let* ((nrol nil) | |
489 | (old (if (eq 'rectangle (car-safe rol)) | |
490 | (nthcdr 4 rol) | |
491 | (funcall redisplay-unhighlight-region-function rol) | |
492 | nil)) | |
493 | (ptcol (progn (goto-char start) (current-column))) | |
494 | (markcol (progn (goto-char end) (current-column))) | |
495 | (leftcol (min ptcol markcol)) | |
496 | (rightcol (max ptcol markcol))) | |
497 | (goto-char start) | |
498 | (while (< (point) end) | |
499 | (let* ((mleft (move-to-column leftcol)) | |
500 | (left (point)) | |
501 | (mright (move-to-column rightcol)) | |
502 | (right (point)) | |
503 | (ol | |
504 | (if (not old) | |
505 | (let ((ol (make-overlay left right))) | |
506 | (overlay-put ol 'window window) | |
507 | (overlay-put ol 'face 'region) | |
508 | ol) | |
509 | (let ((ol (pop old))) | |
510 | (move-overlay ol left right (current-buffer)) | |
511 | ol)))) | |
512 | ;; `move-to-column' may stop before the column (if bumping into | |
513 | ;; EOL) or overshoot it a little, when column is in the middle | |
514 | ;; of a char. | |
515 | (cond | |
516 | ((< mleft leftcol) ;`leftcol' is past EOL. | |
517 | (overlay-put ol 'before-string | |
518 | (spaces-string (- leftcol mleft))) | |
519 | (setq mright (max mright leftcol))) | |
520 | ((and (> mleft leftcol) ;`leftcol' is in the middle of a char. | |
521 | (eq (char-before left) ?\t)) | |
522 | (setq left (1- left)) | |
523 | (move-overlay ol left right) | |
524 | (goto-char left) | |
525 | (overlay-put ol 'before-string | |
526 | (spaces-string (- leftcol (current-column))))) | |
527 | ((overlay-get ol 'before-string) | |
528 | (overlay-put ol 'before-string nil))) | |
529 | (cond | |
530 | ((< mright rightcol) ;`rightcol' is past EOL. | |
531 | (let ((str (make-string (- rightcol mright) ?\s))) | |
532 | (put-text-property 0 (length str) 'face 'region str) | |
533 | ;; If cursor happens to be here, draw it *before* rather than | |
534 | ;; after this highlighted pseudo-text. | |
535 | (put-text-property 0 1 'cursor t str) | |
536 | (overlay-put ol 'after-string str))) | |
537 | ((and (> mright rightcol) ;`rightcol' is in the middle of a char. | |
538 | (eq (char-before right) ?\t)) | |
539 | (setq right (1- right)) | |
540 | (move-overlay ol left right) | |
4aca7145 SM |
541 | (if (= rightcol leftcol) |
542 | (overlay-put ol 'after-string nil) | |
543 | (goto-char right) | |
544 | (let ((str (make-string | |
545 | (- rightcol (max leftcol (current-column))) ?\s))) | |
546 | (put-text-property 0 (length str) 'face 'region str) | |
547 | (when (= left right) | |
548 | ;; If cursor happens to be here, draw it *before* rather | |
549 | ;; than after this highlighted pseudo-text. | |
550 | (put-text-property 0 1 'cursor 1 str)) | |
551 | (overlay-put ol 'after-string str)))) | |
3472b6c6 SM |
552 | ((overlay-get ol 'after-string) |
553 | (overlay-put ol 'after-string nil))) | |
554 | (when (= leftcol rightcol) | |
555 | ;; Make zero-width rectangles visible! | |
556 | (overlay-put ol 'after-string | |
557 | (concat (propertize " " | |
558 | 'face '(region (:height 0.2))) | |
559 | (overlay-get ol 'after-string)))) | |
560 | (push ol nrol)) | |
561 | (forward-line 1)) | |
562 | (mapc #'delete-overlay old) | |
a0d5f7a4 | 563 | `(rectangle ,(buffer-chars-modified-tick) ,start ,end ,@nrol)))))) |
3472b6c6 SM |
564 | |
565 | (defun rectangle--unhighlight-for-redisplay (orig rol) | |
566 | (if (not (eq 'rectangle (car-safe rol))) | |
567 | (funcall orig rol) | |
568 | (mapc #'delete-overlay (nthcdr 4 rol)) | |
569 | (setcar (cdr rol) nil))) | |
570 | ||
08ce70d1 | 571 | (provide 'rect) |
6594deb0 ER |
572 | |
573 | ;;; rect.el ends here |