Commit | Line | Data |
---|---|---|
a2535589 JA |
1 | ;; Rectangle functions for GNU Emacs. |
2 | ;; Copyright (C) 1985 Free Software Foundation, Inc. | |
3 | ||
4 | ;; This file is part of GNU Emacs. | |
5 | ||
6 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
7 | ;; it under the terms of the GNU General Public License as published by | |
8 | ;; the Free Software Foundation; either version 1, or (at your option) | |
9 | ;; any later version. | |
10 | ||
11 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
12 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;; GNU General Public License for more details. | |
15 | ||
16 | ;; You should have received a copy of the GNU General Public License | |
17 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
18 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
19 | ||
20 | ||
21 | (defun operate-on-rectangle (function start end coerce-tabs) | |
22 | "Call FUNCTION for each line of rectangle with corners at START, END. | |
23 | If COERCE-TABS is non-nil, convert multi-column characters | |
24 | that span the starting or ending columns on any line | |
25 | to multiple spaces before calling FUNCTION. | |
26 | FUNCTION is called with three arguments: | |
27 | position of start of segment of this line within the rectangle, | |
28 | number of columns that belong to rectangle but are before that position, | |
29 | number of columns that belong to rectangle but are after point. | |
30 | Point is at the end of the segment of this line within the rectangle." | |
31 | (let (startcol startlinepos endcol endlinepos) | |
32 | (save-excursion | |
33 | (goto-char start) | |
34 | (setq startcol (current-column)) | |
35 | (beginning-of-line) | |
36 | (setq startlinepos (point))) | |
37 | (save-excursion | |
38 | (goto-char end) | |
39 | (setq endcol (current-column)) | |
40 | (forward-line 1) | |
41 | (setq endlinepos (point-marker))) | |
42 | (if (< endcol startcol) | |
43 | (let ((tem startcol)) | |
44 | (setq startcol endcol endcol tem))) | |
45 | (if (/= endcol startcol) | |
46 | (save-excursion | |
47 | (goto-char startlinepos) | |
48 | (while (< (point) endlinepos) | |
49 | (let (startpos begextra endextra) | |
50 | (move-to-column startcol) | |
51 | (and coerce-tabs | |
52 | (> (current-column) startcol) | |
53 | (rectangle-coerce-tab startcol)) | |
54 | (setq begextra (- (current-column) startcol)) | |
55 | (setq startpos (point)) | |
56 | (move-to-column endcol) | |
57 | (if (> (current-column) endcol) | |
58 | (if coerce-tabs | |
59 | (rectangle-coerce-tab endcol) | |
60 | (forward-char -1))) | |
61 | (setq endextra (- endcol (current-column))) | |
62 | (if (< begextra 0) | |
63 | (setq endextra (+ endextra begextra) | |
64 | begextra 0)) | |
65 | (funcall function startpos begextra endextra)) | |
66 | (forward-line 1)))) | |
67 | (- endcol startcol))) | |
68 | ||
69 | (defun delete-rectangle-line (startdelpos ignore ignore) | |
70 | (delete-region startdelpos (point))) | |
71 | ||
72 | (defun delete-extract-rectangle-line (startdelpos begextra endextra) | |
73 | (save-excursion | |
74 | (extract-rectangle-line startdelpos begextra endextra)) | |
75 | (delete-region startdelpos (point))) | |
76 | ||
77 | (defun extract-rectangle-line (startdelpos begextra endextra) | |
78 | (let ((line (buffer-substring startdelpos (point))) | |
79 | (end (point))) | |
80 | (goto-char startdelpos) | |
81 | (while (search-forward "\t" end t) | |
82 | (let ((width (- (current-column) | |
83 | (save-excursion (forward-char -1) | |
84 | (current-column))))) | |
85 | (setq line (concat (substring line 0 (- (point) end 1)) | |
86 | (spaces-string width) | |
87 | (substring line (+ (length line) (- (point) end))))))) | |
88 | (if (or (> begextra 0) (> endextra 0)) | |
89 | (setq line (concat (spaces-string begextra) | |
90 | line | |
91 | (spaces-string endextra)))) | |
92 | (setq lines (cons line lines)))) | |
93 | ||
94 | (defconst spaces-strings | |
95 | '["" " " " " " " " " " " " " " " " "]) | |
96 | ||
97 | (defun spaces-string (n) | |
98 | (if (<= n 8) (aref spaces-strings n) | |
99 | (let ((val "")) | |
100 | (while (> n 8) | |
101 | (setq val (concat " " val) | |
102 | n (- n 8))) | |
103 | (concat val (aref spaces-strings n))))) | |
104 | ||
f9f9507e | 105 | ;;;###autoload |
a2535589 JA |
106 | (defun delete-rectangle (start end) |
107 | "Delete (don't save) text in rectangle with point and mark as corners. | |
573f9b32 RS |
108 | The same range of columns is deleted in each line starting with the line |
109 | where the region begins and ending with the line where the region ends." | |
a2535589 JA |
110 | (interactive "r") |
111 | (operate-on-rectangle 'delete-rectangle-line start end t)) | |
112 | ||
f9f9507e | 113 | ;;;###autoload |
a2535589 JA |
114 | (defun delete-extract-rectangle (start end) |
115 | "Delete contents of rectangle and return it as a list of strings. | |
116 | Arguments START and END are the corners of the rectangle. | |
117 | The value is list of strings, one for each line of the rectangle." | |
118 | (let (lines) | |
119 | (operate-on-rectangle 'delete-extract-rectangle-line | |
120 | start end t) | |
121 | (nreverse lines))) | |
122 | ||
f9f9507e | 123 | ;;;###autoload |
a2535589 JA |
124 | (defun extract-rectangle (start end) |
125 | "Return contents of rectangle with corners at START and END. | |
126 | Value is list of strings, one for each line of the rectangle." | |
127 | (let (lines) | |
128 | (operate-on-rectangle 'extract-rectangle-line start end nil) | |
129 | (nreverse lines))) | |
130 | ||
131 | (defvar killed-rectangle nil | |
132 | "Rectangle for yank-rectangle to insert.") | |
133 | ||
f9f9507e | 134 | ;;;###autoload |
a2535589 JA |
135 | (defun kill-rectangle (start end) |
136 | "Delete rectangle with corners at point and mark; save as last killed one. | |
137 | Calling from program, supply two args START and END, buffer positions. | |
573f9b32 | 138 | But in programs you might prefer to use `delete-extract-rectangle'." |
a2535589 JA |
139 | (interactive "r") |
140 | (setq killed-rectangle (delete-extract-rectangle start end))) | |
141 | ||
f9f9507e | 142 | ;;;###autoload |
a2535589 JA |
143 | (defun yank-rectangle () |
144 | "Yank the last killed rectangle with upper left corner at point." | |
145 | (interactive) | |
146 | (insert-rectangle killed-rectangle)) | |
147 | ||
f9f9507e | 148 | ;;;###autoload |
a2535589 JA |
149 | (defun insert-rectangle (rectangle) |
150 | "Insert text of RECTANGLE with upper left corner at point. | |
573f9b32 RS |
151 | RECTANGLE's first line is inserted at point, its second |
152 | line is inserted at a point vertically under point, etc. | |
a2535589 JA |
153 | RECTANGLE should be a list of strings." |
154 | (let ((lines rectangle) | |
155 | (insertcolumn (current-column)) | |
156 | (first t)) | |
157 | (while lines | |
158 | (or first | |
159 | (progn | |
160 | (forward-line 1) | |
161 | (or (bolp) (insert ?\n)) | |
162 | (move-to-column insertcolumn) | |
163 | (if (> (current-column) insertcolumn) | |
164 | (rectangle-coerce-tab insertcolumn)) | |
165 | (if (< (current-column) insertcolumn) | |
166 | (indent-to insertcolumn)))) | |
167 | (setq first nil) | |
168 | (insert (car lines)) | |
169 | (setq lines (cdr lines))))) | |
170 | ||
f9f9507e | 171 | ;;;###autoload |
a2535589 JA |
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, | |
175 | but insted winds up to the right of the rectangle." | |
176 | (interactive "r") | |
177 | (operate-on-rectangle 'open-rectangle-line start end nil)) | |
178 | ||
179 | (defun open-rectangle-line (startpos begextra endextra) | |
180 | (let ((column (+ (current-column) begextra endextra))) | |
181 | (goto-char startpos) | |
182 | (let ((ocol (current-column))) | |
183 | (skip-chars-forward " \t") | |
184 | (setq column (+ column (- (current-column) ocol)))) | |
185 | (delete-region (point) | |
186 | (progn (skip-chars-backward " \t") | |
187 | (point))) | |
188 | (indent-to column))) | |
189 | ||
f9f9507e | 190 | ;;;###autoload |
a2535589 JA |
191 | (defun clear-rectangle (start end) |
192 | "Blank out rectangle with corners at point and mark. | |
193 | The text previously in the region is overwritten by the blanks. | |
194 | When called from a program, requires two args which specify the corners." | |
195 | (interactive "r") | |
196 | (operate-on-rectangle 'clear-rectangle-line start end t)) | |
197 | ||
198 | (defun clear-rectangle-line (startpos begextra endextra) | |
199 | (skip-chars-forward " \t") | |
200 | (let ((column (+ (current-column) endextra))) | |
201 | (delete-region (point) | |
202 | (progn (goto-char startpos) | |
203 | (skip-chars-backward " \t") | |
204 | (point))) | |
205 | (indent-to column))) | |
206 | ||
207 | (defun rectangle-coerce-tab (column) | |
208 | (let ((aftercol (current-column)) | |
209 | (indent-tabs-mode nil)) | |
210 | (delete-char -1) | |
211 | (indent-to aftercol) | |
212 | (backward-char (- aftercol column)))) |