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