|
0
|
1 ;;; rect.el --- rectangle functions for XEmacs.
|
|
|
2
|
|
|
3 ;; Copyright (C) 1985, 1993, 1994 Free Software Foundation, Inc.
|
|
|
4
|
|
|
5 ;; Maintainer: FSF
|
|
|
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, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
23
|
|
|
24 ;;; Synched up with: FSF 19.30.
|
|
|
25
|
|
|
26 ;;; Commentary:
|
|
|
27
|
|
|
28 ;; This package provides the operations on rectangles that are ocumented
|
|
|
29 ;; in the XEmacs Reference Manual.
|
|
|
30
|
|
|
31 ;;; Code:
|
|
|
32
|
|
|
33 ;; XEmacs: extra-args
|
|
|
34 (defun operate-on-rectangle (function start end coerce-tabs &rest extra-args)
|
|
|
35 "Call FUNCTION for each line of rectangle with corners at START, END.
|
|
|
36 If COERCE-TABS is non-nil, convert multi-column characters
|
|
|
37 that span the starting or ending columns on any line
|
|
|
38 to multiple spaces before calling FUNCTION.
|
|
|
39 FUNCTION is called with three arguments:
|
|
|
40 position of start of segment of this line within the rectangle,
|
|
|
41 number of columns that belong to rectangle but are before that position,
|
|
|
42 number of columns that belong to rectangle but are after point.
|
|
|
43 Point is at the end of the segment of this line within the rectangle."
|
|
|
44 (let (startcol startlinepos endcol endlinepos)
|
|
|
45 (save-excursion
|
|
|
46 (goto-char start)
|
|
|
47 (setq startcol (current-column))
|
|
|
48 (beginning-of-line)
|
|
|
49 (setq startlinepos (point)))
|
|
|
50 (save-excursion
|
|
|
51 (goto-char end)
|
|
|
52 (setq endcol (current-column))
|
|
|
53 (forward-line 1)
|
|
|
54 (setq endlinepos (point-marker)))
|
|
|
55 (if (< endcol startcol)
|
|
|
56 (let ((tem startcol))
|
|
|
57 (setq startcol endcol endcol tem)))
|
|
|
58 (save-excursion
|
|
|
59 (goto-char startlinepos)
|
|
|
60 (while (< (point) endlinepos)
|
|
|
61 (let (startpos begextra endextra)
|
|
|
62 (move-to-column startcol coerce-tabs)
|
|
|
63 (setq begextra (- (current-column) startcol))
|
|
|
64 (setq startpos (point))
|
|
|
65 (move-to-column endcol coerce-tabs)
|
|
|
66 (setq endextra (- endcol (current-column)))
|
|
|
67 (if (< begextra 0)
|
|
|
68 (setq endextra (+ endextra begextra)
|
|
|
69 begextra 0))
|
|
|
70 (apply function startpos begextra endextra extra-args))
|
|
|
71 (forward-line 1)))
|
|
|
72 (- endcol startcol)))
|
|
|
73
|
|
|
74 (defun delete-rectangle-line (startdelpos ignore ignore)
|
|
|
75 (delete-region startdelpos (point)))
|
|
|
76
|
|
|
77 ;; XEmacs: added lines arg
|
|
|
78 (defun delete-extract-rectangle-line (startdelpos begextra endextra lines)
|
|
|
79 (save-excursion
|
|
|
80 (extract-rectangle-line startdelpos begextra endextra lines))
|
|
|
81 (delete-region startdelpos (point)))
|
|
|
82
|
|
|
83 ;; XEmacs: added lines arg
|
|
|
84 (defun extract-rectangle-line (startdelpos begextra endextra lines)
|
|
|
85 (let ((line (buffer-substring startdelpos (point)))
|
|
|
86 (end (point)))
|
|
|
87 (goto-char startdelpos)
|
|
|
88 (while (search-forward "\t" end t)
|
|
|
89 (let ((width (- (current-column)
|
|
|
90 (save-excursion (forward-char -1)
|
|
|
91 (current-column)))))
|
|
|
92 (setq line (concat (substring line 0 (- (point) end 1))
|
|
|
93 (spaces-string width)
|
|
|
94 (substring line (+ (length line) (- (point) end)))))))
|
|
|
95 (if (or (> begextra 0) (> endextra 0))
|
|
|
96 (setq line (concat (spaces-string begextra)
|
|
|
97 line
|
|
|
98 (spaces-string endextra))))
|
|
|
99 (setcdr lines (cons line (cdr lines)))))
|
|
|
100
|
|
|
101 (defconst spaces-strings
|
|
|
102 (purecopy '["" " " " " " " " " " " " " " " " "]))
|
|
|
103
|
|
|
104 (defun spaces-string (n)
|
|
|
105 (if (<= n 8) (aref spaces-strings n)
|
|
|
106 (let ((val ""))
|
|
|
107 (while (> n 8)
|
|
|
108 (setq val (concat " " val)
|
|
|
109 n (- n 8)))
|
|
|
110 (concat val (aref spaces-strings n)))))
|
|
|
111
|
|
|
112 ;;;###autoload
|
|
|
113 (defun delete-rectangle (start end)
|
|
|
114 "Delete (don't save) text in rectangle with point and mark as corners.
|
|
|
115 The same range of columns is deleted in each line
|
|
|
116 starting with the line where the region begins
|
|
|
117 and ending with the line where the region ends."
|
|
|
118 (interactive "r")
|
|
|
119 (operate-on-rectangle 'delete-rectangle-line start end t))
|
|
|
120
|
|
|
121 ;;;###autoload
|
|
|
122 (defun delete-extract-rectangle (start end)
|
|
|
123 "Delete contents of rectangle and return it as a list of strings.
|
|
|
124 Arguments START and END are the corners of the rectangle.
|
|
|
125 The value is list of strings, one for each line of the rectangle."
|
|
|
126 (let ((lines (list nil))) ; XEmacs change
|
|
|
127 (operate-on-rectangle 'delete-extract-rectangle-line
|
|
|
128 start end t lines)
|
|
|
129 (nreverse (cdr lines))))
|
|
|
130
|
|
|
131 ;;;###autoload
|
|
|
132 (defun extract-rectangle (start end)
|
|
|
133 "Return contents of rectangle with corners at START and END.
|
|
|
134 Value is list of strings, one for each line of the rectangle."
|
|
|
135 (let ((lines (list nil))) ; XEmacs change
|
|
|
136 (operate-on-rectangle 'extract-rectangle-line start end nil lines)
|
|
|
137 (nreverse (cdr lines))))
|
|
|
138
|
|
|
139 ;;;###autoload
|
|
|
140 (defvar killed-rectangle nil
|
|
|
141 "Rectangle for yank-rectangle to insert.")
|
|
|
142
|
|
|
143 ;;;###autoload
|
|
|
144 (defun kill-rectangle (start end)
|
|
|
145 "Delete rectangle with corners at point and mark; save as last killed one.
|
|
|
146 Calling from program, supply two args START and END, buffer positions.
|
|
|
147 But in programs you might prefer to use `delete-extract-rectangle'."
|
|
|
148 (interactive "r")
|
|
|
149 (if buffer-read-only
|
|
|
150 (progn
|
|
|
151 (setq killed-rectangle (extract-rectangle start end))
|
|
|
152 (barf-if-buffer-read-only)))
|
|
|
153 (setq killed-rectangle (delete-extract-rectangle start end)))
|
|
|
154
|
|
|
155 ;;;###autoload
|
|
|
156 (defun yank-rectangle ()
|
|
|
157 "Yank the last killed rectangle with upper left corner at point."
|
|
|
158 (interactive)
|
|
|
159 (insert-rectangle killed-rectangle))
|
|
|
160
|
|
|
161 ;;;###autoload
|
|
|
162 (defun insert-rectangle (rectangle)
|
|
|
163 "Insert text of RECTANGLE with upper left corner at point.
|
|
|
164 RECTANGLE's first line is inserted at point,
|
|
|
165 its second line is inserted at a point vertically under point, etc.
|
|
|
166 RECTANGLE should be a list of strings.
|
|
|
167 After this command, the mark is at the upper left corner
|
|
|
168 and point is at the lower right corner."
|
|
|
169 (let ((lines rectangle)
|
|
|
170 (insertcolumn (current-column))
|
|
|
171 (first t))
|
|
|
172 (push-mark)
|
|
|
173 (while lines
|
|
|
174 (or first
|
|
|
175 (progn
|
|
|
176 (forward-line 1)
|
|
|
177 (or (bolp) (insert ?\n))
|
|
|
178 (move-to-column insertcolumn t)))
|
|
|
179 (setq first nil)
|
|
|
180 (insert (car lines))
|
|
|
181 (setq lines (cdr lines)))))
|
|
|
182
|
|
|
183 ;;;###autoload
|
|
|
184 (defun open-rectangle (start end)
|
|
|
185 "Blank out rectangle with corners at point and mark, shifting text right.
|
|
|
186 The text previously in the region is not overwritten by the blanks,
|
|
|
187 but instead winds up to the right of the rectangle."
|
|
|
188 (interactive "r")
|
|
|
189 (operate-on-rectangle 'open-rectangle-line start end nil)
|
|
|
190 (goto-char start))
|
|
|
191
|
|
|
192 (defun open-rectangle-line (startpos begextra endextra)
|
|
|
193 ;; Column where rectangle ends.
|
|
|
194 (let ((endcol (+ (current-column) endextra))
|
|
|
195 whitewidth)
|
|
|
196 (goto-char startpos)
|
|
|
197 ;; Column where rectangle begins.
|
|
|
198 (let ((begcol (- (current-column) begextra)))
|
|
|
199 (skip-chars-forward " \t")
|
|
|
200 ;; Width of whitespace to be deleted and recreated.
|
|
|
201 (setq whitewidth (- (current-column) begcol)))
|
|
|
202 ;; Delete the whitespace following the start column.
|
|
|
203 (delete-region startpos (point))
|
|
|
204 ;; Open the desired width, plus same amount of whitespace we just deleted.
|
|
|
205 (indent-to (+ endcol whitewidth))))
|
|
|
206
|
|
|
207 ;;;###autoload
|
|
|
208 (defun string-rectangle (start end string)
|
|
|
209 "Insert STRING on each line of the region-rectangle, shifting text right.
|
|
|
210 The left edge of the rectangle specifies the column for insertion.
|
|
|
211 This command does not delete or overwrite any existing text.
|
|
|
212
|
|
|
213 Called from a program, takes three args; START, END and STRING."
|
|
|
214 (interactive "r\nsString rectangle: ")
|
|
|
215 (operate-on-rectangle 'string-rectangle-line start end t string))
|
|
|
216
|
|
|
217 ;; XEmacs: add string arg
|
|
|
218 (defun string-rectangle-line (startpos begextra endextra string)
|
|
|
219 (let (whitespace)
|
|
|
220 (goto-char startpos)
|
|
|
221 ;; Compute horizontal width of following whitespace.
|
|
|
222 (let ((ocol (current-column)))
|
|
|
223 (skip-chars-forward " \t")
|
|
|
224 (setq whitespace (- (current-column) ocol)))
|
|
|
225 ;; Delete the following whitespace.
|
|
|
226 (delete-region startpos (point))
|
|
|
227 ;; Insert the desired string.
|
|
|
228 (insert string)
|
|
|
229 ;; Insert the same width of whitespace that we had before.
|
|
|
230 (indent-to (+ (current-column) whitespace))))
|
|
|
231
|
|
|
232 ;;;###autoload
|
|
|
233 (defun clear-rectangle (start end)
|
|
|
234 "Blank out rectangle with corners at point and mark.
|
|
|
235 The text previously in the region is overwritten by the blanks.
|
|
|
236 When called from a program, requires two args which specify the corners."
|
|
|
237 (interactive "r")
|
|
|
238 (operate-on-rectangle 'clear-rectangle-line start end t))
|
|
|
239
|
|
|
240 (defun clear-rectangle-line (startpos begextra endextra)
|
|
|
241 ;; Find end of whitespace after the rectangle.
|
|
|
242 (skip-chars-forward " \t")
|
|
|
243 (let ((column (+ (current-column) endextra)))
|
|
|
244 ;; Delete the text in the rectangle, and following whitespace.
|
|
|
245 (delete-region (point)
|
|
|
246 (progn (goto-char startpos)
|
|
|
247 (skip-chars-backward " \t")
|
|
|
248 (point)))
|
|
|
249 ;; Reindent out to same column that we were at.
|
|
|
250 (indent-to column)))
|
|
|
251
|
|
|
252 ;(defun rectangle-coerce-tab (column)
|
|
|
253 ; (let ((aftercol (current-column))
|
|
|
254 ; (indent-tabs-mode nil))
|
|
|
255 ; (delete-char -1)
|
|
|
256 ; (indent-to aftercol)
|
|
|
257 ; (backward-char (- aftercol column))))
|
|
|
258
|
|
|
259 (provide 'rect)
|
|
|
260
|
|
|
261 ;;; rect.el ends here
|
