Commit | Line | Data |
---|---|---|
6594deb0 ER |
1 | ;;; rect.el --- rectangle functions for GNU Emacs. |
2 | ||
e417c66f | 3 | ;; Copyright (C) 1985, 1999 Free Software Foundation, Inc. |
9750e079 | 4 | |
e417c66f | 5 | ;; Maintainer: Didier Verna <verna@inf.enst.fr> |
d7b4d18f | 6 | ;; Keywords: internal |
4821e2af | 7 | |
a2535589 JA |
8 | ;; This file is part of GNU Emacs. |
9 | ||
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
e5167999 | 12 | ;; the Free Software Foundation; either version 2, or (at your option) |
a2535589 JA |
13 | ;; any later version. |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
b578f267 EN |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 | ;; Boston, MA 02111-1307, USA. | |
a2535589 | 24 | |
edbd2f74 ER |
25 | ;;; Commentary: |
26 | ||
e037c34c | 27 | ;; This package provides the operations on rectangles that are documented |
edbd2f74 ER |
28 | ;; in the Emacs manual. |
29 | ||
e417c66f RS |
30 | ;; ### NOTE: this file has been almost completely rewritten by Didier Verna |
31 | ;; <verna@inf.enst.fr> in July 1999. The purpose of this rewrite is to be less | |
32 | ;; intrusive and fill lines with whitespaces only when needed. A few functions | |
33 | ;; are untouched though, as noted above their definition. | |
34 | ||
35 | ||
4821e2af | 36 | ;;; Code: |
a2535589 | 37 | |
e40261d0 | 38 | ;;;###autoload |
e417c66f | 39 | (defun move-to-column-force (column &optional flag) |
e40261d0 KH |
40 | "Move point to column COLUMN rigidly in the current line. |
41 | If COLUMN is within a multi-column character, replace it by | |
e417c66f RS |
42 | spaces and tab. |
43 | ||
44 | As for `move-to-column', passing anything but nil or t in FLAG will move to | |
45 | the desired column only if the line is long enough." | |
46 | (let ((col (move-to-column column (or flag t)))) | |
e40261d0 KH |
47 | (if (> col column) |
48 | (let (pos) | |
49 | (delete-char -1) | |
50 | (insert-char ? (- column (current-column))) | |
51 | (setq pos (point)) | |
52 | (indent-to col) | |
53 | (goto-char pos))) | |
54 | column)) | |
55 | ||
e417c66f | 56 | ;; not used any more --dv |
3d1b9783 RS |
57 | ;; extract-rectangle-line stores lines into this list |
58 | ;; to accumulate them for extract-rectangle and delete-extract-rectangle. | |
59 | (defvar operate-on-rectangle-lines) | |
60 | ||
e417c66f RS |
61 | ;; ### NOTE: this function is untouched, but not used anymore appart in |
62 | ;; `delete-whitespace-rectangle'. `apply-on-rectangle' is used instead. --dv | |
a2535589 JA |
63 | (defun operate-on-rectangle (function start end coerce-tabs) |
64 | "Call FUNCTION for each line of rectangle with corners at START, END. | |
65 | If COERCE-TABS is non-nil, convert multi-column characters | |
66 | that span the starting or ending columns on any line | |
67 | to multiple spaces before calling FUNCTION. | |
68 | FUNCTION is called with three arguments: | |
69 | position of start of segment of this line within the rectangle, | |
70 | number of columns that belong to rectangle but are before that position, | |
71 | number of columns that belong to rectangle but are after point. | |
72 | Point is at the end of the segment of this line within the rectangle." | |
73 | (let (startcol startlinepos endcol endlinepos) | |
74 | (save-excursion | |
75 | (goto-char start) | |
76 | (setq startcol (current-column)) | |
77 | (beginning-of-line) | |
78 | (setq startlinepos (point))) | |
79 | (save-excursion | |
80 | (goto-char end) | |
81 | (setq endcol (current-column)) | |
82 | (forward-line 1) | |
83 | (setq endlinepos (point-marker))) | |
84 | (if (< endcol startcol) | |
08ce70d1 | 85 | (setq startcol (prog1 endcol (setq endcol startcol)))) |
bc8ea543 RS |
86 | (save-excursion |
87 | (goto-char startlinepos) | |
88 | (while (< (point) endlinepos) | |
89 | (let (startpos begextra endextra) | |
e40261d0 KH |
90 | (if coerce-tabs |
91 | (move-to-column-force startcol) | |
92 | (move-to-column startcol)) | |
bc8ea543 RS |
93 | (setq begextra (- (current-column) startcol)) |
94 | (setq startpos (point)) | |
e40261d0 KH |
95 | (if coerce-tabs |
96 | (move-to-column-force endcol) | |
97 | (move-to-column endcol)) | |
daabd795 RS |
98 | ;; If we overshot, move back one character |
99 | ;; so that endextra will be positive. | |
100 | (if (and (not coerce-tabs) (> (current-column) endcol)) | |
101 | (backward-char 1)) | |
bc8ea543 RS |
102 | (setq endextra (- endcol (current-column))) |
103 | (if (< begextra 0) | |
104 | (setq endextra (+ endextra begextra) | |
105 | begextra 0)) | |
106 | (funcall function startpos begextra endextra)) | |
107 | (forward-line 1))) | |
a2535589 JA |
108 | (- endcol startcol))) |
109 | ||
e417c66f RS |
110 | ;; The replacement for `operate-on-rectangle' -- dv |
111 | (defun apply-on-rectangle (function start end &rest args) | |
112 | "Call FUNCTION for each line of rectangle with corners at START, END. | |
113 | FUNCTION is called with two arguments: the start and end columns of the | |
e037c34c | 114 | rectangle, plus ARGS extra arguments. Point is at the beginning of line when |
e417c66f RS |
115 | the function is called." |
116 | (let (startcol startpt endcol endpt) | |
117 | (save-excursion | |
118 | (goto-char start) | |
119 | (setq startcol (current-column)) | |
120 | (beginning-of-line) | |
121 | (setq startpt (point)) | |
122 | (goto-char end) | |
123 | (setq endcol (current-column)) | |
124 | (forward-line 1) | |
125 | (setq endpt (point-marker)) | |
126 | ;; ensure the start column is the left one. | |
127 | (if (< endcol startcol) | |
128 | (let ((col startcol)) | |
129 | (setq startcol endcol endcol col))) | |
130 | ;; start looping over lines | |
131 | (goto-char startpt) | |
132 | (while (< (point) endpt) | |
133 | (apply function startcol endcol args) | |
134 | (forward-line 1))) | |
135 | )) | |
136 | ||
137 | (defun delete-rectangle-line (startcol endcol fill) | |
6e1e8dbc | 138 | (let ((pt (line-end-position))) |
e417c66f RS |
139 | (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) |
140 | (if (and (not fill) (<= pt endcol)) | |
141 | (delete-region (point) pt) | |
142 | ;; else | |
143 | (setq pt (point)) | |
144 | (move-to-column-force endcol) | |
145 | (delete-region pt (point)))) | |
146 | )) | |
147 | ||
148 | (defun delete-extract-rectangle-line (startcol endcol lines fill) | |
149 | (let ((pt (point-at-eol))) | |
150 | (if (< (move-to-column-force startcol (or fill 'coerce)) startcol) | |
151 | (setcdr lines (cons (spaces-string (- endcol startcol)) | |
152 | (cdr lines))) | |
153 | ;; else | |
154 | (setq pt (point)) | |
155 | (move-to-column-force endcol) | |
156 | (setcdr lines (cons (buffer-substring pt (point)) (cdr lines))) | |
157 | (delete-region pt (point))) | |
158 | )) | |
159 | ||
160 | ;; ### NOTE: this is actually the only function that needs to do complicated | |
161 | ;; stuff like what's happening in `operate-on-rectangle', because the buffer | |
162 | ;; might be read-only. --dv | |
163 | (defun extract-rectangle-line (startcol endcol lines) | |
164 | (let (start end begextra endextra line) | |
165 | (move-to-column startcol) | |
166 | (setq start (point) | |
167 | begextra (- (current-column) startcol)) | |
168 | (move-to-column endcol) | |
169 | (setq end (point) | |
170 | endextra (- endcol (current-column))) | |
171 | (setq line (buffer-substring start (point))) | |
172 | (if (< begextra 0) | |
173 | (setq endextra (+ endextra begextra) | |
174 | begextra 0)) | |
175 | (if (< endextra 0) | |
176 | (setq endextra 0)) | |
177 | (goto-char start) | |
a2535589 JA |
178 | (while (search-forward "\t" end t) |
179 | (let ((width (- (current-column) | |
180 | (save-excursion (forward-char -1) | |
181 | (current-column))))) | |
182 | (setq line (concat (substring line 0 (- (point) end 1)) | |
183 | (spaces-string width) | |
e417c66f RS |
184 | (substring line (+ (length line) |
185 | (- (point) end))))))) | |
a2535589 JA |
186 | (if (or (> begextra 0) (> endextra 0)) |
187 | (setq line (concat (spaces-string begextra) | |
188 | line | |
189 | (spaces-string endextra)))) | |
e417c66f | 190 | (setcdr lines (cons line (cdr lines))))) |
a2535589 JA |
191 | |
192 | (defconst spaces-strings | |
193 | '["" " " " " " " " " " " " " " " " "]) | |
194 | ||
e417c66f | 195 | ;; this one is untouched --dv |
a2535589 JA |
196 | (defun spaces-string (n) |
197 | (if (<= n 8) (aref spaces-strings n) | |
198 | (let ((val "")) | |
199 | (while (> n 8) | |
200 | (setq val (concat " " val) | |
201 | n (- n 8))) | |
202 | (concat val (aref spaces-strings n))))) | |
203 | ||
f9f9507e | 204 | ;;;###autoload |
e417c66f | 205 | (defun delete-rectangle (start end &optional fill) |
e037c34c DL |
206 | "Delete (don't save) text in the region-rectangle. |
207 | The same range of columns is deleted in each line starting with the | |
208 | line where the region begins and ending with the line where the region | |
209 | ends. | |
210 | ||
211 | When called from a program the rectangle's corners are START and END. | |
212 | With a prefix (or a FILL) argument, also fill lines where nothing has | |
213 | to be deleted." | |
214 | (interactive "*r\nP") | |
e417c66f | 215 | (apply-on-rectangle 'delete-rectangle-line start end fill)) |
a2535589 | 216 | |
f9f9507e | 217 | ;;;###autoload |
e417c66f | 218 | (defun delete-extract-rectangle (start end &optional fill) |
7db6139a | 219 | "Delete the contents of the rectangle with corners at START and END. |
e037c34c | 220 | Return it as a list of strings, one for each line of the rectangle. |
e417c66f | 221 | |
e037c34c | 222 | When called from a program the rectangle's corners are START and END. |
e417c66f RS |
223 | With an optional FILL argument, also fill lines where nothing has to be |
224 | deleted." | |
225 | (let ((lines (list nil))) | |
226 | (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill) | |
227 | (nreverse (cdr lines)))) | |
a2535589 | 228 | |
f9f9507e | 229 | ;;;###autoload |
a2535589 | 230 | (defun extract-rectangle (start end) |
e037c34c DL |
231 | "Return the contents of the rectangle with corners at START and END. |
232 | Return it as a list of strings, one for each line of the rectangle." | |
e417c66f RS |
233 | (let ((lines (list nil))) |
234 | (apply-on-rectangle 'extract-rectangle-line start end lines) | |
235 | (nreverse (cdr lines)))) | |
a2535589 JA |
236 | |
237 | (defvar killed-rectangle nil | |
e037c34c | 238 | "Rectangle for `yank-rectangle' to insert.") |
a2535589 | 239 | |
f9f9507e | 240 | ;;;###autoload |
e417c66f | 241 | (defun kill-rectangle (start end &optional fill) |
e037c34c DL |
242 | "Delete the region-rectangle and save it as the last killed one. |
243 | ||
244 | When called from a program the rectangle's corners are START and END. | |
245 | You might prefer to use `delete-extract-rectangle' from a program. | |
e417c66f RS |
246 | |
247 | With a prefix (or a FILL) argument, also fill lines where nothing has to be | |
248 | deleted." | |
e037c34c | 249 | (interactive "*r\nP") |
e417c66f RS |
250 | (when buffer-read-only |
251 | (setq killed-rectangle (extract-rectangle start end)) | |
252 | (barf-if-buffer-read-only)) | |
253 | (setq killed-rectangle (delete-extract-rectangle start end fill))) | |
254 | ||
255 | ;; this one is untouched --dv | |
f9f9507e | 256 | ;;;###autoload |
a2535589 JA |
257 | (defun yank-rectangle () |
258 | "Yank the last killed rectangle with upper left corner at point." | |
e037c34c | 259 | (interactive "*") |
a2535589 JA |
260 | (insert-rectangle killed-rectangle)) |
261 | ||
e417c66f | 262 | ;; this one is untoutched --dv |
f9f9507e | 263 | ;;;###autoload |
a2535589 JA |
264 | (defun insert-rectangle (rectangle) |
265 | "Insert text of RECTANGLE with upper left corner at point. | |
573f9b32 RS |
266 | RECTANGLE's first line is inserted at point, its second |
267 | line is inserted at a point vertically under point, etc. | |
23317eac RS |
268 | RECTANGLE should be a list of strings. |
269 | After this command, the mark is at the upper left corner | |
270 | and point is at the lower right corner." | |
a2535589 JA |
271 | (let ((lines rectangle) |
272 | (insertcolumn (current-column)) | |
273 | (first t)) | |
23317eac | 274 | (push-mark) |
a2535589 JA |
275 | (while lines |
276 | (or first | |
277 | (progn | |
278 | (forward-line 1) | |
279 | (or (bolp) (insert ?\n)) | |
e40261d0 | 280 | (move-to-column-force insertcolumn))) |
a2535589 JA |
281 | (setq first nil) |
282 | (insert (car lines)) | |
283 | (setq lines (cdr lines))))) | |
284 | ||
f9f9507e | 285 | ;;;###autoload |
e417c66f | 286 | (defun open-rectangle (start end &optional fill) |
e037c34c DL |
287 | "Blank out the region-rectangle, shifting text right. |
288 | ||
289 | The text previously in the region is not overwritten by the blanks, | |
290 | but instead winds up to the right of the rectangle. | |
e417c66f | 291 | |
e037c34c | 292 | When called from a program the rectangle's corners are START and END. |
e417c66f RS |
293 | With a prefix (or a FILL) argument, fill with blanks even if there is no text |
294 | on the right side of the rectangle." | |
e037c34c | 295 | (interactive "*r\nP") |
e417c66f | 296 | (apply-on-rectangle 'open-rectangle-line start end fill) |
08ce70d1 | 297 | (goto-char start)) |
a2535589 | 298 | |
e417c66f RS |
299 | (defun open-rectangle-line (startcol endcol fill) |
300 | (let (spaces) | |
301 | (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) | |
302 | (unless (and (not fill) | |
303 | (= (point) (point-at-eol))) | |
304 | (indent-to endcol))) | |
305 | )) | |
306 | ||
307 | (defun delete-whitespace-rectangle-line (startcol endcol fill) | |
308 | (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) | |
309 | (unless (= (point) (point-at-eol)) | |
310 | (delete-region (point) (progn (skip-syntax-forward " ") (point)))) | |
311 | )) | |
a2535589 | 312 | |
ee9ec2a5 | 313 | ;;;###autoload (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name |
ecb079ed | 314 | ;;;###autoload |
e417c66f | 315 | (defun delete-whitespace-rectangle (start end &optional fill) |
ecb079ed RS |
316 | "Delete all whitespace following a specified column in each line. |
317 | The left edge of the rectangle specifies the position in each line | |
318 | at which whitespace deletion should begin. On each line in the | |
e417c66f | 319 | rectangle, all continuous whitespace starting at that column is deleted. |
ecb079ed | 320 | |
e037c34c | 321 | When called from a program the rectangle's corners are START and END. |
e417c66f | 322 | With a prefix (or a FILL) argument, also fill too short lines." |
e037c34c | 323 | (interactive "*r\nP") |
e417c66f RS |
324 | (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill)) |
325 | ||
326 | ;; not used any more --dv | |
3d1b9783 RS |
327 | ;; string-rectangle uses this variable to pass the string |
328 | ;; to string-rectangle-line. | |
329 | (defvar string-rectangle-string) | |
ecb079ed | 330 | |
131ca136 | 331 | ;;;###autoload |
ccb629e4 | 332 | (defun string-rectangle (start end string) |
e037c34c DL |
333 | "Insert STRING on each line of the region-rectangle, shifting text right. |
334 | ||
335 | When called from a program the rectangle's corners are START and END. | |
336 | The left edge of the rectangle specifies the column for insertion. | |
337 | This command does not delete or overwrite any existing text." | |
338 | (interactive "*r\nsString rectangle: ") | |
e417c66f RS |
339 | (apply-on-rectangle 'string-rectangle-line start end string)) |
340 | ||
341 | (defun string-rectangle-line (startcol endcol string) | |
342 | (move-to-column-force startcol) | |
343 | (insert string)) | |
131ca136 | 344 | |
852eeeaf DL |
345 | ;;;###autoload |
346 | (defun replace-rectangle (start end string) | |
347 | "Like `string-rectangle', but replace the original region." | |
348 | (interactive "*r\nsString rectangle: ") | |
349 | (apply-on-rectangle 'string-rectangle-line start end string t)) | |
350 | ||
f9f9507e | 351 | ;;;###autoload |
e417c66f | 352 | (defun clear-rectangle (start end &optional fill) |
e037c34c DL |
353 | "Blank out the region-rectangle. |
354 | The text previously in the region is overwritten with blanks. | |
e417c66f | 355 | |
e037c34c | 356 | When called from a program the rectangle's corners are START and END. |
e417c66f RS |
357 | With a prefix (or a FILL) argument, also fill with blanks the parts of the |
358 | rectangle which were empty." | |
e037c34c | 359 | (interactive "*r\nP") |
e417c66f RS |
360 | (apply-on-rectangle 'clear-rectangle-line start end fill)) |
361 | ||
362 | (defun clear-rectangle-line (startcol endcol fill) | |
363 | (let ((pt (point-at-eol)) | |
364 | spaces) | |
365 | (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) | |
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)) | |
371 | (move-to-column-force endcol) | |
372 | (setq spaces (- (point) pt)) | |
373 | (delete-region pt (point)) | |
374 | (indent-to (+ (current-column) spaces)))) | |
375 | )) | |
a2535589 | 376 | |
08ce70d1 | 377 | (provide 'rect) |
6594deb0 ER |
378 | |
379 | ;;; rect.el ends here |