Mercurial > emacs
annotate lisp/rect.el @ 6063:233fffcfb6c8
(Fget_char_property): New function.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Thu, 24 Feb 1994 19:18:32 +0000 |
parents | bef3a67ac893 |
children | 4fd40bd394fe |
rev | line source |
---|---|
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
1 ;;; rect.el --- rectangle functions for GNU Emacs. |
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
2 |
845 | 3 ;; Copyright (C) 1985 Free Software Foundation, Inc. |
4 | |
789
71d052f72ac1
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
5 ;; Maintainer: FSF |
814
38b2499cb3e9
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
807
diff
changeset
|
6 ;; Keywords: internal |
789
71d052f72ac1
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
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
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
789
diff
changeset
|
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 | |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
23 | |
2308
f287613dfc28
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1619
diff
changeset
|
24 ;;; Commentary: |
f287613dfc28
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1619
diff
changeset
|
25 |
f287613dfc28
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1619
diff
changeset
|
26 ;; This package provides the operations on rectangles that are ocumented |
f287613dfc28
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1619
diff
changeset
|
27 ;; in the Emacs manual. |
f287613dfc28
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1619
diff
changeset
|
28 |
789
71d052f72ac1
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
29 ;;; Code: |
36 | 30 |
31 (defun operate-on-rectangle (function start end coerce-tabs) | |
32 "Call FUNCTION for each line of rectangle with corners at START, END. | |
33 If COERCE-TABS is non-nil, convert multi-column characters | |
34 that span the starting or ending columns on any line | |
35 to multiple spaces before calling FUNCTION. | |
36 FUNCTION is called with three arguments: | |
37 position of start of segment of this line within the rectangle, | |
38 number of columns that belong to rectangle but are before that position, | |
39 number of columns that belong to rectangle but are after point. | |
40 Point is at the end of the segment of this line within the rectangle." | |
41 (let (startcol startlinepos endcol endlinepos) | |
42 (save-excursion | |
43 (goto-char start) | |
44 (setq startcol (current-column)) | |
45 (beginning-of-line) | |
46 (setq startlinepos (point))) | |
47 (save-excursion | |
48 (goto-char end) | |
49 (setq endcol (current-column)) | |
50 (forward-line 1) | |
51 (setq endlinepos (point-marker))) | |
52 (if (< endcol startcol) | |
1619
6147d2164331
* rect.el (operate-on-rectangle): Use move-to-column's FORCE
Jim Blandy <jimb@redhat.com>
parents:
1542
diff
changeset
|
53 (setq startcol (prog1 endcol (setq endcol startcol)))) |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
54 (save-excursion |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
55 (goto-char startlinepos) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
56 (while (< (point) endlinepos) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
57 (let (startpos begextra endextra) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
58 (move-to-column startcol coerce-tabs) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
59 (setq begextra (- (current-column) startcol)) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
60 (setq startpos (point)) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
61 (move-to-column endcol coerce-tabs) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
62 (setq endextra (- endcol (current-column))) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
63 (if (< begextra 0) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
64 (setq endextra (+ endextra begextra) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
65 begextra 0)) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
66 (funcall function startpos begextra endextra)) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
67 (forward-line 1))) |
36 | 68 (- endcol startcol))) |
69 | |
70 (defun delete-rectangle-line (startdelpos ignore ignore) | |
71 (delete-region startdelpos (point))) | |
72 | |
73 (defun delete-extract-rectangle-line (startdelpos begextra endextra) | |
74 (save-excursion | |
75 (extract-rectangle-line startdelpos begextra endextra)) | |
76 (delete-region startdelpos (point))) | |
77 | |
78 (defun extract-rectangle-line (startdelpos begextra endextra) | |
79 (let ((line (buffer-substring startdelpos (point))) | |
80 (end (point))) | |
81 (goto-char startdelpos) | |
82 (while (search-forward "\t" end t) | |
83 (let ((width (- (current-column) | |
84 (save-excursion (forward-char -1) | |
85 (current-column))))) | |
86 (setq line (concat (substring line 0 (- (point) end 1)) | |
87 (spaces-string width) | |
88 (substring line (+ (length line) (- (point) end))))))) | |
89 (if (or (> begextra 0) (> endextra 0)) | |
90 (setq line (concat (spaces-string begextra) | |
91 line | |
92 (spaces-string endextra)))) | |
93 (setq lines (cons line lines)))) | |
94 | |
95 (defconst spaces-strings | |
96 '["" " " " " " " " " " " " " " " " "]) | |
97 | |
98 (defun spaces-string (n) | |
99 (if (<= n 8) (aref spaces-strings n) | |
100 (let ((val "")) | |
101 (while (> n 8) | |
102 (setq val (concat " " val) | |
103 n (- n 8))) | |
104 (concat val (aref spaces-strings n))))) | |
105 | |
258 | 106 ;;;###autoload |
36 | 107 (defun delete-rectangle (start end) |
108 "Delete (don't save) text in rectangle with point and mark as corners. | |
242 | 109 The same range of columns is deleted in each line starting with the line |
110 where the region begins and ending with the line where the region ends." | |
36 | 111 (interactive "r") |
112 (operate-on-rectangle 'delete-rectangle-line start end t)) | |
113 | |
258 | 114 ;;;###autoload |
36 | 115 (defun delete-extract-rectangle (start end) |
116 "Delete contents of rectangle and return it as a list of strings. | |
117 Arguments START and END are the corners of the rectangle. | |
118 The value is list of strings, one for each line of the rectangle." | |
119 (let (lines) | |
120 (operate-on-rectangle 'delete-extract-rectangle-line | |
121 start end t) | |
122 (nreverse lines))) | |
123 | |
258 | 124 ;;;###autoload |
36 | 125 (defun extract-rectangle (start end) |
126 "Return contents of rectangle with corners at START and END. | |
127 Value is list of strings, one for each line of the rectangle." | |
128 (let (lines) | |
129 (operate-on-rectangle 'extract-rectangle-line start end nil) | |
130 (nreverse lines))) | |
131 | |
132 (defvar killed-rectangle nil | |
133 "Rectangle for yank-rectangle to insert.") | |
134 | |
258 | 135 ;;;###autoload |
36 | 136 (defun kill-rectangle (start end) |
137 "Delete rectangle with corners at point and mark; save as last killed one. | |
138 Calling from program, supply two args START and END, buffer positions. | |
242 | 139 But in programs you might prefer to use `delete-extract-rectangle'." |
36 | 140 (interactive "r") |
141 (setq killed-rectangle (delete-extract-rectangle start end))) | |
142 | |
258 | 143 ;;;###autoload |
36 | 144 (defun yank-rectangle () |
145 "Yank the last killed rectangle with upper left corner at point." | |
146 (interactive) | |
147 (insert-rectangle killed-rectangle)) | |
148 | |
258 | 149 ;;;###autoload |
36 | 150 (defun insert-rectangle (rectangle) |
151 "Insert text of RECTANGLE with upper left corner at point. | |
242 | 152 RECTANGLE's first line is inserted at point, its second |
153 line is inserted at a point vertically under point, etc. | |
1542
724b443e445d
(insert-rectangle): Put mark at upper left corner.
Richard M. Stallman <rms@gnu.org>
parents:
845
diff
changeset
|
154 RECTANGLE should be a list of strings. |
724b443e445d
(insert-rectangle): Put mark at upper left corner.
Richard M. Stallman <rms@gnu.org>
parents:
845
diff
changeset
|
155 After this command, the mark is at the upper left corner |
724b443e445d
(insert-rectangle): Put mark at upper left corner.
Richard M. Stallman <rms@gnu.org>
parents:
845
diff
changeset
|
156 and point is at the lower right corner." |
36 | 157 (let ((lines rectangle) |
158 (insertcolumn (current-column)) | |
159 (first t)) | |
1542
724b443e445d
(insert-rectangle): Put mark at upper left corner.
Richard M. Stallman <rms@gnu.org>
parents:
845
diff
changeset
|
160 (push-mark) |
36 | 161 (while lines |
162 (or first | |
163 (progn | |
164 (forward-line 1) | |
165 (or (bolp) (insert ?\n)) | |
1619
6147d2164331
* rect.el (operate-on-rectangle): Use move-to-column's FORCE
Jim Blandy <jimb@redhat.com>
parents:
1542
diff
changeset
|
166 (move-to-column insertcolumn t))) |
36 | 167 (setq first nil) |
168 (insert (car lines)) | |
169 (setq lines (cdr lines))))) | |
170 | |
258 | 171 ;;;###autoload |
36 | 172 (defun open-rectangle (start end) |
173 "Blank out rectangle with corners at point and mark, shifting text right. | |
174 The text previously in the region is not overwritten by the blanks, | |
1619
6147d2164331
* rect.el (operate-on-rectangle): Use move-to-column's FORCE
Jim Blandy <jimb@redhat.com>
parents:
1542
diff
changeset
|
175 but instead winds up to the right of the rectangle." |
36 | 176 (interactive "r") |
1619
6147d2164331
* rect.el (operate-on-rectangle): Use move-to-column's FORCE
Jim Blandy <jimb@redhat.com>
parents:
1542
diff
changeset
|
177 (operate-on-rectangle 'open-rectangle-line start end nil) |
6147d2164331
* rect.el (operate-on-rectangle): Use move-to-column's FORCE
Jim Blandy <jimb@redhat.com>
parents:
1542
diff
changeset
|
178 (goto-char start)) |
36 | 179 |
180 (defun open-rectangle-line (startpos begextra endextra) | |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
181 ;; Column where rectangle ends. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
182 (let ((endcol (+ (current-column) endextra)) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
183 whitewidth) |
36 | 184 (goto-char startpos) |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
185 ;; Column where rectangle begins. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
186 (let ((begcol (- (current-column) begextra))) |
36 | 187 (skip-chars-forward " \t") |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
188 ;; Width of whitespace to be deleted and recreated. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
189 (setq whitewidth (- (current-column) begcol))) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
190 ;; Delete the whitespace following the start column. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
191 (delete-region startpos (point)) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
192 ;; Open the desired width, plus same amount of whitespace we just deleted. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
193 (indent-to (+ endcol whitewidth)))) |
36 | 194 |
258 | 195 ;;;###autoload |
2637
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
196 (defun string-rectangle (start end string) |
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
197 "Insert STRING on each line of the region-rectangle, shifting text right. |
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
198 The left edge of the rectangle specifies the column for insertion. |
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
199 This command does not delete or overwrite any existing text. |
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
200 |
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
201 Called from a program, takes three args; START, END and STRING." |
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
202 (interactive "r\nsString rectangle: ") |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
203 (operate-on-rectangle 'string-rectangle-line start end t) |
2380
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2308
diff
changeset
|
204 (goto-char start)) |
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2308
diff
changeset
|
205 |
2637
45ecb9b4a6da
(string-rectangle): Renamed from fill-rectangle.
Richard M. Stallman <rms@gnu.org>
parents:
2380
diff
changeset
|
206 (defun string-rectangle-line (startpos begextra endextra) |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
207 (let (whitespace) |
2380
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2308
diff
changeset
|
208 (goto-char startpos) |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
209 ;; Compute horizontal width of following whitespace. |
2380
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2308
diff
changeset
|
210 (let ((ocol (current-column))) |
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2308
diff
changeset
|
211 (skip-chars-forward " \t") |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
212 (setq whitespace (- (current-column) ocol))) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
213 ;; Delete the following whitespace. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
214 (delete-region startpos (point)) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
215 ;; Insert the desired string. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
216 (insert string) |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
217 ;; Insert the same width of whitespace that we had before. |
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
218 (indent-to (+ (current-column) whitespace)))) |
2380
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2308
diff
changeset
|
219 |
e67f6d2679e3
(fill-rectangle) Added. Inspired by Lynn Slater's insert-box package in LCD,
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2308
diff
changeset
|
220 ;;;###autoload |
36 | 221 (defun clear-rectangle (start end) |
222 "Blank out rectangle with corners at point and mark. | |
223 The text previously in the region is overwritten by the blanks. | |
224 When called from a program, requires two args which specify the corners." | |
225 (interactive "r") | |
226 (operate-on-rectangle 'clear-rectangle-line start end t)) | |
227 | |
228 (defun clear-rectangle-line (startpos begextra endextra) | |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
229 ;; Find end of whitespace after the rectangle. |
36 | 230 (skip-chars-forward " \t") |
231 (let ((column (+ (current-column) endextra))) | |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
232 ;; Delete the text in the rectangle, and following whitespace. |
36 | 233 (delete-region (point) |
234 (progn (goto-char startpos) | |
235 (skip-chars-backward " \t") | |
236 (point))) | |
5787
bef3a67ac893
(string-rectangle): Make operate-on-rectangle convert tabs.
Richard M. Stallman <rms@gnu.org>
parents:
2637
diff
changeset
|
237 ;; Reindent out to same column that we were at. |
36 | 238 (indent-to column))) |
239 | |
1619
6147d2164331
* rect.el (operate-on-rectangle): Use move-to-column's FORCE
Jim Blandy <jimb@redhat.com>
parents:
1542
diff
changeset
|
240 (provide 'rect) |
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
241 |
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
242 ;;; rect.el ends here |