Commit | Line | Data |
---|---|---|
3472b6c6 | 1 | ;;; rect.el --- rectangle functions for GNU Emacs -*- lexical-binding:t -*- |
6594deb0 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1985, 1999-2014 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 | |
7e74ad02 SM |
34 | (eval-when-compile (require 'cl-lib)) |
35 | ||
5139e960 SM |
36 | (defgroup rectangle nil |
37 | "Operations on rectangles." | |
38 | :version "24.5" | |
39 | :group 'editing) | |
40 | ||
5614fd56 | 41 | ;; FIXME: this function should be replaced by `apply-on-rectangle' |
a2535589 JA |
42 | (defun operate-on-rectangle (function start end coerce-tabs) |
43 | "Call FUNCTION for each line of rectangle with corners at START, END. | |
44 | If COERCE-TABS is non-nil, convert multi-column characters | |
45 | that span the starting or ending columns on any line | |
46 | to multiple spaces before calling FUNCTION. | |
47 | FUNCTION 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. | |
51 | Point is at the end of the segment of this line within the rectangle." | |
7e74ad02 SM |
52 | (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 | 76 | (defun rectangle--pos-cols (start end &optional window) |
7e74ad02 SM |
77 | ;; 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 | 80 | (let ((cw (window-parameter window 'rectangle--point-crutches))) |
7e74ad02 SM |
81 | (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))) | |
116 | ;; If move-to-column over-shooted, move back one char so we're | |
117 | ;; 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 | 141 | |
e417c66f RS |
142 | (defun apply-on-rectangle (function start end &rest args) |
143 | "Call FUNCTION for each line of rectangle with corners at START, END. | |
144 | FUNCTION is called with two arguments: the start and end columns of the | |
e037c34c | 145 | rectangle, plus ARGS extra arguments. Point is at the beginning of line when |
7509a874 LMI |
146 | the function is called. |
147 | The final point after the last operation will be returned." | |
7e74ad02 SM |
148 | (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 |
157 | (if (< endcol startcol) |
158 | (let ((col startcol)) | |
159 | (setq startcol endcol endcol col))) | |
7e74ad02 | 160 | ;; Start looping over lines. |
e417c66f | 161 | (goto-char startpt) |
7e74ad02 SM |
162 | (while |
163 | (progn | |
164 | (apply function startcol endcol args) | |
165 | (setq final-point (point)) | |
166 | (and (zerop (forward-line 1)) | |
167 | (<= (point) endpt)))) | |
168 | final-point))) | |
e417c66f RS |
169 | |
170 | (defun delete-rectangle-line (startcol endcol fill) | |
b29b5c24 | 171 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
b9e81d0a SM |
172 | (delete-region (point) |
173 | (progn (move-to-column endcol 'coerce) | |
174 | (point))))) | |
e417c66f RS |
175 | |
176 | (defun delete-extract-rectangle-line (startcol endcol lines fill) | |
177 | (let ((pt (point-at-eol))) | |
b29b5c24 | 178 | (if (< (move-to-column startcol (if fill t 'coerce)) startcol) |
e417c66f RS |
179 | (setcdr lines (cons (spaces-string (- endcol startcol)) |
180 | (cdr lines))) | |
181 | ;; else | |
182 | (setq pt (point)) | |
b9e81d0a | 183 | (move-to-column endcol t) |
5c831ccd | 184 | (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines)))) |
e417c66f RS |
185 | )) |
186 | ||
5614fd56 CY |
187 | ;; 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 |
190 | (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 |
205 | (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 |
211 | (substring line (+ (length line) |
212 | (- (point) end))))))) | |
a2535589 JA |
213 | (if (or (> begextra 0) (> endextra 0)) |
214 | (setq line (concat (spaces-string begextra) | |
215 | line | |
216 | (spaces-string endextra)))) | |
e417c66f | 217 | (setcdr lines (cons line (cdr lines))))) |
a2535589 JA |
218 | |
219 | (defconst spaces-strings | |
220 | '["" " " " " " " " " " " " " " " " "]) | |
221 | ||
222 | (defun spaces-string (n) | |
6cda144f | 223 | "Return a string with N spaces." |
a2535589 | 224 | (if (<= n 8) (aref spaces-strings n) |
6cda144f | 225 | (make-string n ?\s))) |
f1180544 | 226 | |
f9f9507e | 227 | ;;;###autoload |
e417c66f | 228 | (defun delete-rectangle (start end &optional fill) |
e037c34c DL |
229 | "Delete (don't save) text in the region-rectangle. |
230 | The same range of columns is deleted in each line starting with the | |
231 | line where the region begins and ending with the line where the region | |
232 | ends. | |
233 | ||
234 | When called from a program the rectangle's corners are START and END. | |
235 | With a prefix (or a FILL) argument, also fill lines where nothing has | |
236 | to be deleted." | |
237 | (interactive "*r\nP") | |
e417c66f | 238 | (apply-on-rectangle 'delete-rectangle-line start end fill)) |
a2535589 | 239 | |
f9f9507e | 240 | ;;;###autoload |
e417c66f | 241 | (defun delete-extract-rectangle (start end &optional fill) |
7db6139a | 242 | "Delete the contents of the rectangle with corners at START and END. |
e037c34c | 243 | Return it as a list of strings, one for each line of the rectangle. |
e417c66f | 244 | |
e037c34c | 245 | When called from a program the rectangle's corners are START and END. |
e417c66f RS |
246 | With an optional FILL argument, also fill lines where nothing has to be |
247 | deleted." | |
248 | (let ((lines (list nil))) | |
249 | (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill) | |
250 | (nreverse (cdr lines)))) | |
a2535589 | 251 | |
f9f9507e | 252 | ;;;###autoload |
a2535589 | 253 | (defun extract-rectangle (start end) |
e037c34c DL |
254 | "Return the contents of the rectangle with corners at START and END. |
255 | Return it as a list of strings, one for each line of the rectangle." | |
e417c66f RS |
256 | (let ((lines (list nil))) |
257 | (apply-on-rectangle 'extract-rectangle-line start end lines) | |
258 | (nreverse (cdr lines)))) | |
a2535589 JA |
259 | |
260 | (defvar killed-rectangle nil | |
e037c34c | 261 | "Rectangle for `yank-rectangle' to insert.") |
a2535589 | 262 | |
f9f9507e | 263 | ;;;###autoload |
e417c66f | 264 | (defun kill-rectangle (start end &optional fill) |
e037c34c DL |
265 | "Delete the region-rectangle and save it as the last killed one. |
266 | ||
267 | When called from a program the rectangle's corners are START and END. | |
268 | You might prefer to use `delete-extract-rectangle' from a program. | |
e417c66f RS |
269 | |
270 | With a prefix (or a FILL) argument, also fill lines where nothing has to be | |
5c831ccd EZ |
271 | deleted. |
272 | ||
273 | If the buffer is read-only, Emacs will beep and refrain from deleting | |
274 | the rectangle, but put it in the kill ring anyway. This means that | |
275 | you 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 | |
277 | even 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 | 282 | (setq deactivate-mark t) |
5c831ccd EZ |
283 | (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 | 288 | |
be755c79 RT |
289 | ;;;###autoload |
290 | (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 |
294 | (setq deactivate-mark t) |
295 | (if (called-interactively-p 'interactive) | |
296 | (indicate-copied-region (length (car killed-rectangle))))) | |
be755c79 | 297 | |
f9f9507e | 298 | ;;;###autoload |
a2535589 JA |
299 | (defun yank-rectangle () |
300 | "Yank the last killed rectangle with upper left corner at point." | |
e037c34c | 301 | (interactive "*") |
a2535589 JA |
302 | (insert-rectangle killed-rectangle)) |
303 | ||
f9f9507e | 304 | ;;;###autoload |
a2535589 JA |
305 | (defun insert-rectangle (rectangle) |
306 | "Insert text of RECTANGLE with upper left corner at point. | |
573f9b32 RS |
307 | RECTANGLE's first line is inserted at point, its second |
308 | line is inserted at a point vertically under point, etc. | |
23317eac RS |
309 | RECTANGLE should be a list of strings. |
310 | After this command, the mark is at the upper left corner | |
311 | and point is at the lower right corner." | |
a2535589 JA |
312 | (let ((lines rectangle) |
313 | (insertcolumn (current-column)) | |
314 | (first t)) | |
23317eac | 315 | (push-mark) |
a2535589 JA |
316 | (while lines |
317 | (or first | |
318 | (progn | |
319 | (forward-line 1) | |
320 | (or (bolp) (insert ?\n)) | |
b9e81d0a | 321 | (move-to-column insertcolumn t))) |
a2535589 | 322 | (setq first nil) |
afa0467f | 323 | (insert-for-yank (car lines)) |
a2535589 JA |
324 | (setq lines (cdr lines))))) |
325 | ||
f9f9507e | 326 | ;;;###autoload |
e417c66f | 327 | (defun open-rectangle (start end &optional fill) |
e037c34c DL |
328 | "Blank out the region-rectangle, shifting text right. |
329 | ||
330 | The text previously in the region is not overwritten by the blanks, | |
331 | but instead winds up to the right of the rectangle. | |
e417c66f | 332 | |
e037c34c | 333 | When called from a program the rectangle's corners are START and END. |
6cda144f JB |
334 | With a prefix (or a FILL) argument, fill with blanks even if there is |
335 | no text on the right side of the rectangle." | |
e037c34c | 336 | (interactive "*r\nP") |
e417c66f | 337 | (apply-on-rectangle 'open-rectangle-line start end fill) |
08ce70d1 | 338 | (goto-char start)) |
a2535589 | 339 | |
e417c66f | 340 | (defun open-rectangle-line (startcol endcol fill) |
b29b5c24 | 341 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
74be0ade DL |
342 | (unless (and (not fill) |
343 | (= (point) (point-at-eol))) | |
344 | (indent-to endcol)))) | |
e417c66f | 345 | |
06b60517 | 346 | (defun delete-whitespace-rectangle-line (startcol _endcol fill) |
b29b5c24 | 347 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
e417c66f | 348 | (unless (= (point) (point-at-eol)) |
35f901fa | 349 | (delete-region (point) (progn (skip-syntax-forward " ") (point)))))) |
a2535589 | 350 | |
b3a4edce MR |
351 | ;;;###autoload |
352 | (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name | |
353 | ||
ecb079ed | 354 | ;;;###autoload |
e417c66f | 355 | (defun delete-whitespace-rectangle (start end &optional fill) |
ecb079ed RS |
356 | "Delete all whitespace following a specified column in each line. |
357 | The left edge of the rectangle specifies the position in each line | |
358 | at which whitespace deletion should begin. On each line in the | |
e417c66f | 359 | rectangle, all continuous whitespace starting at that column is deleted. |
ecb079ed | 360 | |
e037c34c | 361 | When called from a program the rectangle's corners are START and END. |
e417c66f | 362 | With a prefix (or a FILL) argument, also fill too short lines." |
e037c34c | 363 | (interactive "*r\nP") |
e417c66f RS |
364 | (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill)) |
365 | ||
b9e81d0a | 366 | (defvar string-rectangle-history nil) |
197615f3 | 367 | (defun string-rectangle-line (startcol endcol string delete) |
b9e81d0a | 368 | (move-to-column startcol t) |
197615f3 DL |
369 | (if delete |
370 | (delete-rectangle-line startcol endcol nil)) | |
e417c66f | 371 | (insert string)) |
131ca136 | 372 | |
5139e960 SM |
373 | (defvar-local rectangle--string-preview-state nil) |
374 | (defvar-local rectangle--string-preview-window nil) | |
375 | ||
376 | (defun rectangle--string-flush-preview () | |
377 | (mapc #'delete-overlay (nthcdr 3 rectangle--string-preview-state)) | |
378 | (setf (nthcdr 3 rectangle--string-preview-state) nil)) | |
379 | ||
380 | (defun rectangle--string-erase-preview () | |
381 | (with-selected-window rectangle--string-preview-window | |
382 | (rectangle--string-flush-preview))) | |
383 | ||
384 | (defun rectangle--space-to (col) | |
385 | (propertize " " 'display `(space :align-to ,col))) | |
386 | ||
387 | (defface rectangle-preview-face '((t :inherit region)) | |
388 | "The face to use for the `string-rectangle' preview.") | |
389 | ||
390 | (defcustom rectangle-preview t | |
391 | "If non-nil, `string-rectangle' will show an-the-fly preview." | |
392 | :type 'boolean) | |
393 | ||
394 | (defun rectangle--string-preview () | |
395 | (let ((str (minibuffer-contents))) | |
396 | (when (equal str "") | |
397 | (setq str (or (car-safe minibuffer-default) | |
398 | (if (stringp minibuffer-default) minibuffer-default)))) | |
399 | (setq str (propertize str 'face 'region)) | |
400 | (with-selected-window rectangle--string-preview-window | |
401 | (unless (or (null rectangle--string-preview-state) | |
402 | (equal str (car rectangle--string-preview-state))) | |
403 | (rectangle--string-flush-preview) | |
404 | (apply-on-rectangle | |
405 | (lambda (startcol endcol) | |
406 | (let* ((sc (move-to-column startcol)) | |
407 | (start (if (<= sc startcol) (point) | |
408 | (forward-char -1) | |
409 | (setq sc (current-column)) | |
410 | (point))) | |
411 | (ec (move-to-column endcol)) | |
412 | (end (point)) | |
413 | (ol (make-overlay start end))) | |
414 | (push ol (nthcdr 3 rectangle--string-preview-state)) | |
415 | ;; FIXME: The extra spacing doesn't interact correctly with | |
416 | ;; the extra spacing added by the rectangular-region-highlight. | |
417 | (when (< sc startcol) | |
418 | (overlay-put ol 'before-string (rectangle--space-to startcol))) | |
419 | (let ((as (when (< endcol ec) | |
420 | ;; (rectangle--space-to ec) | |
421 | (spaces-string (- ec endcol)) | |
422 | ))) | |
423 | (if (= start end) | |
424 | (overlay-put ol 'after-string (if as (concat str as) str)) | |
425 | (overlay-put ol 'display str) | |
426 | (if as (overlay-put ol 'after-string as)))))) | |
427 | (nth 1 rectangle--string-preview-state) | |
428 | (nth 2 rectangle--string-preview-state)))))) | |
429 | ||
430 | ;; FIXME: Should this be turned into inhibit-region-highlight and made to apply | |
431 | ;; to non-rectangular regions as well? | |
432 | (defvar rectangle--inhibit-region-highlight nil) | |
433 | ||
852eeeaf | 434 | ;;;###autoload |
35f901fa GM |
435 | (defun string-rectangle (start end string) |
436 | "Replace rectangle contents with STRING on each line. | |
437 | The length of STRING need not be the same as the rectangle width. | |
438 | ||
439 | Called from a program, takes three args; START, END and STRING." | |
b9e81d0a | 440 | (interactive |
5139e960 SM |
441 | (progn |
442 | (make-local-variable 'rectangle--string-preview-state) | |
443 | (make-local-variable 'rectangle--inhibit-region-highlight) | |
444 | (let* ((buf (current-buffer)) | |
445 | (win (if (eq (window-buffer) buf) (selected-window))) | |
446 | (start (region-beginning)) | |
447 | (end (region-end)) | |
448 | (rectangle--string-preview-state `(nil ,start ,end)) | |
449 | ;; Rectangle-region-highlighting doesn't work well in the presence | |
450 | ;; of the preview overlays. We could work harder to try and make | |
451 | ;; it work better, but it's easier to just disable it temporarily. | |
452 | (rectangle--inhibit-region-highlight t)) | |
453 | (barf-if-buffer-read-only) | |
454 | (list start end | |
455 | (minibuffer-with-setup-hook | |
456 | (lambda () | |
457 | (setq rectangle--string-preview-window win) | |
458 | (add-hook 'minibuffer-exit-hook | |
459 | #'rectangle--string-erase-preview nil t) | |
460 | (add-hook 'post-command-hook | |
461 | #'rectangle--string-preview nil t)) | |
5b76833f | 462 | (read-string (format "String rectangle (default %s): " |
b9e81d0a SM |
463 | (or (car string-rectangle-history) "")) |
464 | nil 'string-rectangle-history | |
5139e960 | 465 | (car string-rectangle-history))))))) |
7509a874 LMI |
466 | (goto-char |
467 | (apply-on-rectangle 'string-rectangle-line start end string t))) | |
852eeeaf | 468 | |
0c54cd99 | 469 | ;;;###autoload |
35f901fa GM |
470 | (defalias 'replace-rectangle 'string-rectangle) |
471 | ||
472 | ;;;###autoload | |
473 | (defun string-insert-rectangle (start end string) | |
474 | "Insert STRING on each line of region-rectangle, shifting text right. | |
475 | ||
476 | When called from a program, the rectangle's corners are START and END. | |
477 | The left edge of the rectangle specifies the column for insertion. | |
478 | This command does not delete or overwrite any existing text." | |
b9e81d0a SM |
479 | (interactive |
480 | (progn (barf-if-buffer-read-only) | |
481 | (list | |
482 | (region-beginning) | |
483 | (region-end) | |
5b76833f | 484 | (read-string (format "String insert rectangle (default %s): " |
b9e81d0a SM |
485 | (or (car string-rectangle-history) "")) |
486 | nil 'string-rectangle-history | |
487 | (car string-rectangle-history))))) | |
35f901fa GM |
488 | (apply-on-rectangle 'string-rectangle-line start end string nil)) |
489 | ||
f9f9507e | 490 | ;;;###autoload |
e417c66f | 491 | (defun clear-rectangle (start end &optional fill) |
e037c34c DL |
492 | "Blank out the region-rectangle. |
493 | The text previously in the region is overwritten with blanks. | |
e417c66f | 494 | |
e037c34c | 495 | When called from a program the rectangle's corners are START and END. |
e417c66f RS |
496 | With a prefix (or a FILL) argument, also fill with blanks the parts of the |
497 | rectangle which were empty." | |
e037c34c | 498 | (interactive "*r\nP") |
e417c66f RS |
499 | (apply-on-rectangle 'clear-rectangle-line start end fill)) |
500 | ||
501 | (defun clear-rectangle-line (startcol endcol fill) | |
7dfee029 | 502 | (let ((pt (point-at-eol))) |
b29b5c24 | 503 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
e417c66f RS |
504 | (if (and (not fill) |
505 | (<= (save-excursion (goto-char pt) (current-column)) endcol)) | |
506 | (delete-region (point) pt) | |
507 | ;; else | |
508 | (setq pt (point)) | |
b9e81d0a | 509 | (move-to-column endcol t) |
7dfee029 | 510 | (setq endcol (current-column)) |
e417c66f | 511 | (delete-region pt (point)) |
7dfee029 | 512 | (indent-to endcol))))) |
a2535589 | 513 | |
99f053cf JA |
514 | ;; Line numbers for `rectangle-number-line-callback'. |
515 | (defvar rectangle-number-line-counter) | |
516 | ||
06b60517 | 517 | (defun rectangle-number-line-callback (start _end format-string) |
99f053cf JA |
518 | (move-to-column start t) |
519 | (insert (format format-string rectangle-number-line-counter)) | |
520 | (setq rectangle-number-line-counter | |
521 | (1+ rectangle-number-line-counter))) | |
522 | ||
523 | (defun rectange--default-line-number-format (start end start-at) | |
524 | (concat "%" | |
525 | (int-to-string (length (int-to-string (+ (count-lines start end) | |
526 | start-at)))) | |
527 | "d ")) | |
528 | ||
529 | ;;;###autoload | |
530 | (defun rectangle-number-lines (start end start-at &optional format) | |
531 | "Insert numbers in front of the region-rectangle. | |
532 | ||
533 | START-AT, if non-nil, should be a number from which to begin | |
534 | counting. FORMAT, if non-nil, should be a format string to pass | |
535 | to `format' along with the line count. When called interactively | |
536 | with a prefix argument, prompt for START-AT and FORMAT." | |
537 | (interactive | |
538 | (if current-prefix-arg | |
539 | (let* ((start (region-beginning)) | |
540 | (end (region-end)) | |
541 | (start-at (read-number "Number to count from: " 1))) | |
542 | (list start end start-at | |
543 | (read-string "Format string: " | |
544 | (rectange--default-line-number-format | |
545 | start end start-at)))) | |
546 | (list (region-beginning) (region-end) 1 nil))) | |
547 | (unless format | |
548 | (setq format (rectange--default-line-number-format start end start-at))) | |
549 | (let ((rectangle-number-line-counter start-at)) | |
550 | (apply-on-rectangle 'rectangle-number-line-callback | |
551 | start end format))) | |
552 | ||
3472b6c6 SM |
553 | ;;; New rectangle integration with kill-ring. |
554 | ||
7818df11 | 555 | ;; FIXME: known problems with the new rectangle support: |
3472b6c6 SM |
556 | ;; - lots of commands handle the region without paying attention to its |
557 | ;; rectangular shape. | |
558 | ||
3472b6c6 SM |
559 | (add-function :around redisplay-highlight-region-function |
560 | #'rectangle--highlight-for-redisplay) | |
561 | (add-function :around redisplay-unhighlight-region-function | |
562 | #'rectangle--unhighlight-for-redisplay) | |
563 | (add-function :around region-extract-function | |
564 | #'rectangle--extract-region) | |
565 | ||
4aca7145 SM |
566 | (defvar rectangle-mark-mode-map |
567 | (let ((map (make-sparse-keymap))) | |
568 | (define-key map [?\C-o] 'open-rectangle) | |
569 | (define-key map [?\C-t] 'string-rectangle) | |
7e74ad02 SM |
570 | (define-key map [remap exchange-point-and-mark] |
571 | 'rectangle-exchange-point-and-mark) | |
572 | (dolist (cmd '(right-char left-char forward-char backward-char | |
573 | next-line previous-line)) | |
574 | (define-key map (vector 'remap cmd) | |
575 | (intern (format "rectangle-%s" cmd)))) | |
4aca7145 SM |
576 | map) |
577 | "Keymap used while marking a rectangular region.") | |
578 | ||
3472b6c6 | 579 | ;;;###autoload |
4aca7145 SM |
580 | (define-minor-mode rectangle-mark-mode |
581 | "Toggle the region as rectangular. | |
582 | Activates the region if needed. Only lasts until the region is deactivated." | |
583 | nil nil nil | |
7e74ad02 | 584 | (rectangle--reset-crutches) |
4aca7145 | 585 | (when rectangle-mark-mode |
2013a2f9 SM |
586 | (add-hook 'deactivate-mark-hook |
587 | (lambda () (rectangle-mark-mode -1))) | |
02033d49 SM |
588 | (unless (region-active-p) |
589 | (push-mark) | |
d791cc3b BG |
590 | (activate-mark) |
591 | (message "Mark set (rectangle mode)")))) | |
3472b6c6 | 592 | |
7e74ad02 SM |
593 | (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. | |
669 | Ignores `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. | |
676 | Ignores `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 | 683 | (defun rectangle--extract-region (orig &optional delete) |
4aca7145 | 684 | (if (not rectangle-mark-mode) |
3472b6c6 SM |
685 | (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 |
712 | (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 |
717 | (defun rectangle--highlight-for-redisplay (orig start end window rol) |
718 | (cond | |
4aca7145 | 719 | ((not rectangle-mark-mode) |
3472b6c6 | 720 | (funcall orig start end window rol)) |
5139e960 SM |
721 | (rectangle--inhibit-region-highlight |
722 | (rectangle--unhighlight-for-redisplay orig rol) | |
723 | nil) | |
3472b6c6 | 724 | ((and (eq 'rectangle (car-safe rol)) |
a0d5f7a4 | 725 | (eq (nth 1 rol) (buffer-chars-modified-tick)) |
3472b6c6 | 726 | (eq start (nth 2 rol)) |
7e74ad02 SM |
727 | (eq end (nth 3 rol)) |
728 | (equal (rectangle--crutches) (nth 4 rol))) | |
3472b6c6 SM |
729 | rol) |
730 | (t | |
731 | (save-excursion | |
732 | (let* ((nrol nil) | |
733 | (old (if (eq 'rectangle (car-safe rol)) | |
7e74ad02 | 734 | (nthcdr 5 rol) |
3472b6c6 | 735 | (funcall redisplay-unhighlight-region-function rol) |
7e74ad02 | 736 | nil))) |
5139e960 SM |
737 | (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 | 789 | (put-text-property 0 (length str) 'face 'region str) |
5139e960 SM |
790 | ;; 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 | 815 | (mapc #'delete-overlay old) |
7e74ad02 SM |
816 | `(rectangle ,(buffer-chars-modified-tick) |
817 | ,start ,end ,(rectangle--crutches) | |
818 | ,@nrol)))))) | |
3472b6c6 SM |
819 | |
820 | (defun rectangle--unhighlight-for-redisplay (orig rol) | |
821 | (if (not (eq 'rectangle (car-safe rol))) | |
822 | (funcall orig rol) | |
7e74ad02 | 823 | (mapc #'delete-overlay (nthcdr 5 rol)) |
3472b6c6 SM |
824 | (setcar (cdr rol) nil))) |
825 | ||
08ce70d1 | 826 | (provide 'rect) |
6594deb0 ER |
827 | |
828 | ;;; rect.el ends here |