38436
|
1 ;;; rect.el --- rectangle functions for GNU Emacs
|
659
|
2
|
37444
|
3 ;; Copyright (C) 1985, 1999, 2000, 2001 Free Software Foundation, Inc.
|
845
|
4
|
39537
|
5 ;; Maintainer: Didier Verna <didier@xemacs.org>
|
814
|
6 ;; Keywords: internal
|
789
|
7
|
36
|
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
|
807
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
36
|
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
|
14169
|
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.
|
36
|
24
|
2308
|
25 ;;; Commentary:
|
|
26
|
25379
|
27 ;; This package provides the operations on rectangles that are documented
|
2308
|
28 ;; in the Emacs manual.
|
|
29
|
25168
|
30 ;; ### NOTE: this file has been almost completely rewritten by Didier Verna
|
39537
|
31 ;; <didier@xemacs.org> in July 1999. The purpose of this rewrite is to be less
|
25168
|
32 ;; intrusive and fill lines with whitespaces only when needed. A few functions
|
|
33 ;; are untouched though, as noted above their definition.
|
|
34
|
|
35
|
789
|
36 ;;; Code:
|
36
|
37
|
23757
|
38 ;;;###autoload
|
25168
|
39 (defun move-to-column-force (column &optional flag)
|
46054
|
40 "If COLUMN is within a multi-column character, replace it by spaces and tab.
|
25168
|
41 As for `move-to-column', passing anything but nil or t in FLAG will move to
|
|
42 the desired column only if the line is long enough."
|
41173
|
43 (move-to-column column (or flag t)))
|
46512
8e08ec435afd
(move-to-column-force): Add autoload cookie to obsolescence declaration.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
44
|
8e08ec435afd
(move-to-column-force): Add autoload cookie to obsolescence declaration.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
45 ;;;###autoload
|
46054
|
46 (make-obsolete 'move-to-column-force 'move-to-column "21.2")
|
23757
|
47
|
25168
|
48 ;; not used any more --dv
|
22213
|
49 ;; extract-rectangle-line stores lines into this list
|
|
50 ;; to accumulate them for extract-rectangle and delete-extract-rectangle.
|
|
51 (defvar operate-on-rectangle-lines)
|
|
52
|
30283
|
53 ;; ### NOTE: this function is untouched, but not used anymore apart from
|
25168
|
54 ;; `delete-whitespace-rectangle'. `apply-on-rectangle' is used instead. --dv
|
36
|
55 (defun operate-on-rectangle (function start end coerce-tabs)
|
|
56 "Call FUNCTION for each line of rectangle with corners at START, END.
|
|
57 If COERCE-TABS is non-nil, convert multi-column characters
|
|
58 that span the starting or ending columns on any line
|
|
59 to multiple spaces before calling FUNCTION.
|
|
60 FUNCTION is called with three arguments:
|
|
61 position of start of segment of this line within the rectangle,
|
|
62 number of columns that belong to rectangle but are before that position,
|
|
63 number of columns that belong to rectangle but are after point.
|
|
64 Point is at the end of the segment of this line within the rectangle."
|
|
65 (let (startcol startlinepos endcol endlinepos)
|
|
66 (save-excursion
|
|
67 (goto-char start)
|
|
68 (setq startcol (current-column))
|
|
69 (beginning-of-line)
|
|
70 (setq startlinepos (point)))
|
|
71 (save-excursion
|
|
72 (goto-char end)
|
|
73 (setq endcol (current-column))
|
|
74 (forward-line 1)
|
|
75 (setq endlinepos (point-marker)))
|
|
76 (if (< endcol startcol)
|
1619
|
77 (setq startcol (prog1 endcol (setq endcol startcol))))
|
5787
|
78 (save-excursion
|
|
79 (goto-char startlinepos)
|
|
80 (while (< (point) endlinepos)
|
|
81 (let (startpos begextra endextra)
|
23757
|
82 (if coerce-tabs
|
41173
|
83 (move-to-column startcol t)
|
23757
|
84 (move-to-column startcol))
|
5787
|
85 (setq begextra (- (current-column) startcol))
|
|
86 (setq startpos (point))
|
23757
|
87 (if coerce-tabs
|
41173
|
88 (move-to-column endcol t)
|
23757
|
89 (move-to-column endcol))
|
19732
d8478556c7f0
(operate-on-rectangle): If we overshoot when looking for endcol, back up.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
90 ;; If we overshot, move back one character
|
d8478556c7f0
(operate-on-rectangle): If we overshoot when looking for endcol, back up.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
91 ;; so that endextra will be positive.
|
d8478556c7f0
(operate-on-rectangle): If we overshoot when looking for endcol, back up.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
92 (if (and (not coerce-tabs) (> (current-column) endcol))
|
d8478556c7f0
(operate-on-rectangle): If we overshoot when looking for endcol, back up.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
93 (backward-char 1))
|
5787
|
94 (setq endextra (- endcol (current-column)))
|
|
95 (if (< begextra 0)
|
|
96 (setq endextra (+ endextra begextra)
|
|
97 begextra 0))
|
|
98 (funcall function startpos begextra endextra))
|
|
99 (forward-line 1)))
|
36
|
100 (- endcol startcol)))
|
|
101
|
25168
|
102 ;; The replacement for `operate-on-rectangle' -- dv
|
|
103 (defun apply-on-rectangle (function start end &rest args)
|
|
104 "Call FUNCTION for each line of rectangle with corners at START, END.
|
|
105 FUNCTION is called with two arguments: the start and end columns of the
|
25379
|
106 rectangle, plus ARGS extra arguments. Point is at the beginning of line when
|
25168
|
107 the function is called."
|
|
108 (let (startcol startpt endcol endpt)
|
|
109 (save-excursion
|
|
110 (goto-char start)
|
|
111 (setq startcol (current-column))
|
|
112 (beginning-of-line)
|
|
113 (setq startpt (point))
|
|
114 (goto-char end)
|
|
115 (setq endcol (current-column))
|
|
116 (forward-line 1)
|
|
117 (setq endpt (point-marker))
|
|
118 ;; ensure the start column is the left one.
|
|
119 (if (< endcol startcol)
|
|
120 (let ((col startcol))
|
|
121 (setq startcol endcol endcol col)))
|
|
122 ;; start looping over lines
|
|
123 (goto-char startpt)
|
|
124 (while (< (point) endpt)
|
|
125 (apply function startcol endcol args)
|
|
126 (forward-line 1)))
|
|
127 ))
|
36
|
128
|
25168
|
129 (defun delete-rectangle-line (startcol endcol fill)
|
41173
|
130 (when (= (move-to-column startcol (or fill 'coerce)) startcol)
|
|
131 (delete-region (point)
|
|
132 (progn (move-to-column endcol 'coerce)
|
|
133 (point)))))
|
36
|
134
|
25168
|
135 (defun delete-extract-rectangle-line (startcol endcol lines fill)
|
|
136 (let ((pt (point-at-eol)))
|
41173
|
137 (if (< (move-to-column startcol (or fill 'coerce)) startcol)
|
25168
|
138 (setcdr lines (cons (spaces-string (- endcol startcol))
|
|
139 (cdr lines)))
|
|
140 ;; else
|
|
141 (setq pt (point))
|
41173
|
142 (move-to-column endcol t)
|
25168
|
143 (setcdr lines (cons (buffer-substring pt (point)) (cdr lines)))
|
|
144 (delete-region pt (point)))
|
|
145 ))
|
|
146
|
|
147 ;; ### NOTE: this is actually the only function that needs to do complicated
|
|
148 ;; stuff like what's happening in `operate-on-rectangle', because the buffer
|
|
149 ;; might be read-only. --dv
|
|
150 (defun extract-rectangle-line (startcol endcol lines)
|
|
151 (let (start end begextra endextra line)
|
|
152 (move-to-column startcol)
|
|
153 (setq start (point)
|
|
154 begextra (- (current-column) startcol))
|
|
155 (move-to-column endcol)
|
|
156 (setq end (point)
|
|
157 endextra (- endcol (current-column)))
|
|
158 (setq line (buffer-substring start (point)))
|
|
159 (if (< begextra 0)
|
|
160 (setq endextra (+ endextra begextra)
|
|
161 begextra 0))
|
|
162 (if (< endextra 0)
|
|
163 (setq endextra 0))
|
|
164 (goto-char start)
|
36
|
165 (while (search-forward "\t" end t)
|
|
166 (let ((width (- (current-column)
|
|
167 (save-excursion (forward-char -1)
|
|
168 (current-column)))))
|
|
169 (setq line (concat (substring line 0 (- (point) end 1))
|
|
170 (spaces-string width)
|
25168
|
171 (substring line (+ (length line)
|
|
172 (- (point) end)))))))
|
36
|
173 (if (or (> begextra 0) (> endextra 0))
|
|
174 (setq line (concat (spaces-string begextra)
|
|
175 line
|
|
176 (spaces-string endextra))))
|
25168
|
177 (setcdr lines (cons line (cdr lines)))))
|
36
|
178
|
|
179 (defconst spaces-strings
|
|
180 '["" " " " " " " " " " " " " " " " "])
|
|
181
|
25168
|
182 ;; this one is untouched --dv
|
36
|
183 (defun spaces-string (n)
|
|
184 (if (<= n 8) (aref spaces-strings n)
|
|
185 (let ((val ""))
|
|
186 (while (> n 8)
|
|
187 (setq val (concat " " val)
|
|
188 n (- n 8)))
|
|
189 (concat val (aref spaces-strings n)))))
|
49597
|
190
|
258
|
191 ;;;###autoload
|
25168
|
192 (defun delete-rectangle (start end &optional fill)
|
25379
|
193 "Delete (don't save) text in the region-rectangle.
|
|
194 The same range of columns is deleted in each line starting with the
|
|
195 line where the region begins and ending with the line where the region
|
|
196 ends.
|
25168
|
197
|
25379
|
198 When called from a program the rectangle's corners are START and END.
|
|
199 With a prefix (or a FILL) argument, also fill lines where nothing has
|
|
200 to be deleted."
|
|
201 (interactive "*r\nP")
|
25168
|
202 (apply-on-rectangle 'delete-rectangle-line start end fill))
|
36
|
203
|
258
|
204 ;;;###autoload
|
25168
|
205 (defun delete-extract-rectangle (start end &optional fill)
|
25380
|
206 "Delete the contents of the rectangle with corners at START and END.
|
25379
|
207 Return it as a list of strings, one for each line of the rectangle.
|
25168
|
208
|
25379
|
209 When called from a program the rectangle's corners are START and END.
|
25168
|
210 With an optional FILL argument, also fill lines where nothing has to be
|
|
211 deleted."
|
|
212 (let ((lines (list nil)))
|
|
213 (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill)
|
|
214 (nreverse (cdr lines))))
|
36
|
215
|
258
|
216 ;;;###autoload
|
36
|
217 (defun extract-rectangle (start end)
|
25379
|
218 "Return the contents of the rectangle with corners at START and END.
|
|
219 Return it as a list of strings, one for each line of the rectangle."
|
25168
|
220 (let ((lines (list nil)))
|
|
221 (apply-on-rectangle 'extract-rectangle-line start end lines)
|
|
222 (nreverse (cdr lines))))
|
36
|
223
|
|
224 (defvar killed-rectangle nil
|
25379
|
225 "Rectangle for `yank-rectangle' to insert.")
|
36
|
226
|
258
|
227 ;;;###autoload
|
25168
|
228 (defun kill-rectangle (start end &optional fill)
|
25379
|
229 "Delete the region-rectangle and save it as the last killed one.
|
|
230
|
|
231 When called from a program the rectangle's corners are START and END.
|
|
232 You might prefer to use `delete-extract-rectangle' from a program.
|
36
|
233
|
25168
|
234 With a prefix (or a FILL) argument, also fill lines where nothing has to be
|
|
235 deleted."
|
25379
|
236 (interactive "*r\nP")
|
25168
|
237 (when buffer-read-only
|
|
238 (setq killed-rectangle (extract-rectangle start end))
|
|
239 (barf-if-buffer-read-only))
|
|
240 (setq killed-rectangle (delete-extract-rectangle start end fill)))
|
|
241
|
|
242 ;; this one is untouched --dv
|
258
|
243 ;;;###autoload
|
36
|
244 (defun yank-rectangle ()
|
|
245 "Yank the last killed rectangle with upper left corner at point."
|
25379
|
246 (interactive "*")
|
36
|
247 (insert-rectangle killed-rectangle))
|
|
248
|
25168
|
249 ;; this one is untoutched --dv
|
258
|
250 ;;;###autoload
|
36
|
251 (defun insert-rectangle (rectangle)
|
|
252 "Insert text of RECTANGLE with upper left corner at point.
|
242
|
253 RECTANGLE's first line is inserted at point, its second
|
|
254 line is inserted at a point vertically under point, etc.
|
1542
|
255 RECTANGLE should be a list of strings.
|
|
256 After this command, the mark is at the upper left corner
|
|
257 and point is at the lower right corner."
|
36
|
258 (let ((lines rectangle)
|
|
259 (insertcolumn (current-column))
|
|
260 (first t))
|
1542
|
261 (push-mark)
|
36
|
262 (while lines
|
|
263 (or first
|
|
264 (progn
|
|
265 (forward-line 1)
|
|
266 (or (bolp) (insert ?\n))
|
41173
|
267 (move-to-column insertcolumn t)))
|
36
|
268 (setq first nil)
|
44676
|
269 (insert-for-yank (car lines))
|
36
|
270 (setq lines (cdr lines)))))
|
|
271
|
258
|
272 ;;;###autoload
|
25168
|
273 (defun open-rectangle (start end &optional fill)
|
25379
|
274 "Blank out the region-rectangle, shifting text right.
|
25168
|
275
|
25379
|
276 The text previously in the region is not overwritten by the blanks,
|
|
277 but instead winds up to the right of the rectangle.
|
|
278
|
|
279 When called from a program the rectangle's corners are START and END.
|
25168
|
280 With a prefix (or a FILL) argument, fill with blanks even if there is no text
|
|
281 on the right side of the rectangle."
|
25379
|
282 (interactive "*r\nP")
|
25168
|
283 (apply-on-rectangle 'open-rectangle-line start end fill)
|
1619
|
284 (goto-char start))
|
36
|
285
|
25168
|
286 (defun open-rectangle-line (startcol endcol fill)
|
41173
|
287 (when (= (move-to-column startcol (or fill 'coerce)) startcol)
|
30283
|
288 (unless (and (not fill)
|
|
289 (= (point) (point-at-eol)))
|
|
290 (indent-to endcol))))
|
25168
|
291
|
|
292 (defun delete-whitespace-rectangle-line (startcol endcol fill)
|
41173
|
293 (when (= (move-to-column startcol (or fill 'coerce)) startcol)
|
25168
|
294 (unless (= (point) (point-at-eol))
|
37444
|
295 (delete-region (point) (progn (skip-syntax-forward " ") (point))))))
|
36
|
296
|
45168
4f3c96288c84
(close-rectangle): Don't hide it behind the autoload-cookie.
Markus Rost <rost@math.uni-bielefeld.de>
diff
changeset
|
297 ;;;###autoload
|
4f3c96288c84
(close-rectangle): Don't hide it behind the autoload-cookie.
Markus Rost <rost@math.uni-bielefeld.de>
diff
changeset
|
298 (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name
|
4f3c96288c84
(close-rectangle): Don't hide it behind the autoload-cookie.
Markus Rost <rost@math.uni-bielefeld.de>
diff
changeset
|
299
|
258
|
300 ;;;###autoload
|
25168
|
301 (defun delete-whitespace-rectangle (start end &optional fill)
|
22205
|
302 "Delete all whitespace following a specified column in each line.
|
|
303 The left edge of the rectangle specifies the position in each line
|
|
304 at which whitespace deletion should begin. On each line in the
|
25168
|
305 rectangle, all continuous whitespace starting at that column is deleted.
|
22205
|
306
|
25379
|
307 When called from a program the rectangle's corners are START and END.
|
25168
|
308 With a prefix (or a FILL) argument, also fill too short lines."
|
25379
|
309 (interactive "*r\nP")
|
25168
|
310 (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill))
|
|
311
|
|
312 ;; not used any more --dv
|
22213
|
313 ;; string-rectangle uses this variable to pass the string
|
|
314 ;; to string-rectangle-line.
|
|
315 (defvar string-rectangle-string)
|
41173
|
316 (defvar string-rectangle-history nil)
|
33772
|
317 (defun string-rectangle-line (startcol endcol string delete)
|
41173
|
318 (move-to-column startcol t)
|
33772
|
319 (if delete
|
|
320 (delete-rectangle-line startcol endcol nil))
|
25168
|
321 (insert string))
|
2380
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
diff
changeset
|
322
|
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
diff
changeset
|
323 ;;;###autoload
|
37444
|
324 (defun string-rectangle (start end string)
|
|
325 "Replace rectangle contents with STRING on each line.
|
|
326 The length of STRING need not be the same as the rectangle width.
|
|
327
|
|
328 Called from a program, takes three args; START, END and STRING."
|
41173
|
329 (interactive
|
|
330 (progn (barf-if-buffer-read-only)
|
|
331 (list
|
|
332 (region-beginning)
|
|
333 (region-end)
|
|
334 (read-string (format "String rectangle (default `%s'): "
|
|
335 (or (car string-rectangle-history) ""))
|
|
336 nil 'string-rectangle-history
|
|
337 (car string-rectangle-history)))))
|
33772
|
338 (apply-on-rectangle 'string-rectangle-line start end string t))
|
28078
|
339
|
44207
|
340 ;;;###autoload
|
37444
|
341 (defalias 'replace-rectangle 'string-rectangle)
|
|
342
|
|
343 ;;;###autoload
|
|
344 (defun string-insert-rectangle (start end string)
|
|
345 "Insert STRING on each line of region-rectangle, shifting text right.
|
|
346
|
|
347 When called from a program, the rectangle's corners are START and END.
|
|
348 The left edge of the rectangle specifies the column for insertion.
|
|
349 This command does not delete or overwrite any existing text."
|
41173
|
350 (interactive
|
|
351 (progn (barf-if-buffer-read-only)
|
|
352 (list
|
|
353 (region-beginning)
|
|
354 (region-end)
|
|
355 (read-string (format "String insert rectangle (default `%s'): "
|
|
356 (or (car string-rectangle-history) ""))
|
|
357 nil 'string-rectangle-history
|
|
358 (car string-rectangle-history)))))
|
37444
|
359 (apply-on-rectangle 'string-rectangle-line start end string nil))
|
|
360
|
28078
|
361 ;;;###autoload
|
25168
|
362 (defun clear-rectangle (start end &optional fill)
|
25379
|
363 "Blank out the region-rectangle.
|
|
364 The text previously in the region is overwritten with blanks.
|
25168
|
365
|
25379
|
366 When called from a program the rectangle's corners are START and END.
|
25168
|
367 With a prefix (or a FILL) argument, also fill with blanks the parts of the
|
|
368 rectangle which were empty."
|
25379
|
369 (interactive "*r\nP")
|
25168
|
370 (apply-on-rectangle 'clear-rectangle-line start end fill))
|
36
|
371
|
25168
|
372 (defun clear-rectangle-line (startcol endcol fill)
|
43555
|
373 (let ((pt (point-at-eol)))
|
41173
|
374 (when (= (move-to-column startcol (or fill 'coerce)) startcol)
|
25168
|
375 (if (and (not fill)
|
|
376 (<= (save-excursion (goto-char pt) (current-column)) endcol))
|
|
377 (delete-region (point) pt)
|
|
378 ;; else
|
|
379 (setq pt (point))
|
41173
|
380 (move-to-column endcol t)
|
43555
|
381 (setq endcol (current-column))
|
25168
|
382 (delete-region pt (point))
|
43555
|
383 (indent-to endcol)))))
|
36
|
384
|
1619
|
385 (provide 'rect)
|
659
|
386
|
|
387 ;;; rect.el ends here
|