Mercurial > emacs
annotate lisp/rect.el @ 1456:5f42c7680da7
(ange-ftp-add-vms-host, ange-ftp-add-dl-dir, ange-ftp-add-mts-host):
(ange-ftp-add-dumb-unix-host): Use default-directory, not dired-directory.
(ange-ftp-allow-child-lookup): Eliminate use of dired-local-variables-file.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Tue, 20 Oct 1992 07:05:38 +0000 |
parents | 213978acbc1e |
children | 724b443e445d |
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 | |
789
71d052f72ac1
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
24 ;;; Code: |
36 | 25 |
26 (defun operate-on-rectangle (function start end coerce-tabs) | |
27 "Call FUNCTION for each line of rectangle with corners at START, END. | |
28 If COERCE-TABS is non-nil, convert multi-column characters | |
29 that span the starting or ending columns on any line | |
30 to multiple spaces before calling FUNCTION. | |
31 FUNCTION is called with three arguments: | |
32 position of start of segment of this line within the rectangle, | |
33 number of columns that belong to rectangle but are before that position, | |
34 number of columns that belong to rectangle but are after point. | |
35 Point is at the end of the segment of this line within the rectangle." | |
36 (let (startcol startlinepos endcol endlinepos) | |
37 (save-excursion | |
38 (goto-char start) | |
39 (setq startcol (current-column)) | |
40 (beginning-of-line) | |
41 (setq startlinepos (point))) | |
42 (save-excursion | |
43 (goto-char end) | |
44 (setq endcol (current-column)) | |
45 (forward-line 1) | |
46 (setq endlinepos (point-marker))) | |
47 (if (< endcol startcol) | |
48 (let ((tem startcol)) | |
49 (setq startcol endcol endcol tem))) | |
50 (if (/= endcol startcol) | |
51 (save-excursion | |
52 (goto-char startlinepos) | |
53 (while (< (point) endlinepos) | |
54 (let (startpos begextra endextra) | |
55 (move-to-column startcol) | |
56 (and coerce-tabs | |
57 (> (current-column) startcol) | |
58 (rectangle-coerce-tab startcol)) | |
59 (setq begextra (- (current-column) startcol)) | |
60 (setq startpos (point)) | |
61 (move-to-column endcol) | |
62 (if (> (current-column) endcol) | |
63 (if coerce-tabs | |
64 (rectangle-coerce-tab endcol) | |
65 (forward-char -1))) | |
66 (setq endextra (- endcol (current-column))) | |
67 (if (< begextra 0) | |
68 (setq endextra (+ endextra begextra) | |
69 begextra 0)) | |
70 (funcall function startpos begextra endextra)) | |
71 (forward-line 1)))) | |
72 (- endcol startcol))) | |
73 | |
74 (defun delete-rectangle-line (startdelpos ignore ignore) | |
75 (delete-region startdelpos (point))) | |
76 | |
77 (defun delete-extract-rectangle-line (startdelpos begextra endextra) | |
78 (save-excursion | |
79 (extract-rectangle-line startdelpos begextra endextra)) | |
80 (delete-region startdelpos (point))) | |
81 | |
82 (defun extract-rectangle-line (startdelpos begextra endextra) | |
83 (let ((line (buffer-substring startdelpos (point))) | |
84 (end (point))) | |
85 (goto-char startdelpos) | |
86 (while (search-forward "\t" end t) | |
87 (let ((width (- (current-column) | |
88 (save-excursion (forward-char -1) | |
89 (current-column))))) | |
90 (setq line (concat (substring line 0 (- (point) end 1)) | |
91 (spaces-string width) | |
92 (substring line (+ (length line) (- (point) end))))))) | |
93 (if (or (> begextra 0) (> endextra 0)) | |
94 (setq line (concat (spaces-string begextra) | |
95 line | |
96 (spaces-string endextra)))) | |
97 (setq lines (cons line lines)))) | |
98 | |
99 (defconst spaces-strings | |
100 '["" " " " " " " " " " " " " " " " "]) | |
101 | |
102 (defun spaces-string (n) | |
103 (if (<= n 8) (aref spaces-strings n) | |
104 (let ((val "")) | |
105 (while (> n 8) | |
106 (setq val (concat " " val) | |
107 n (- n 8))) | |
108 (concat val (aref spaces-strings n))))) | |
109 | |
258 | 110 ;;;###autoload |
36 | 111 (defun delete-rectangle (start end) |
112 "Delete (don't save) text in rectangle with point and mark as corners. | |
242 | 113 The same range of columns is deleted in each line starting with the line |
114 where the region begins and ending with the line where the region ends." | |
36 | 115 (interactive "r") |
116 (operate-on-rectangle 'delete-rectangle-line start end t)) | |
117 | |
258 | 118 ;;;###autoload |
36 | 119 (defun delete-extract-rectangle (start end) |
120 "Delete contents of rectangle and return it as a list of strings. | |
121 Arguments START and END are the corners of the rectangle. | |
122 The value is list of strings, one for each line of the rectangle." | |
123 (let (lines) | |
124 (operate-on-rectangle 'delete-extract-rectangle-line | |
125 start end t) | |
126 (nreverse lines))) | |
127 | |
258 | 128 ;;;###autoload |
36 | 129 (defun extract-rectangle (start end) |
130 "Return contents of rectangle with corners at START and END. | |
131 Value is list of strings, one for each line of the rectangle." | |
132 (let (lines) | |
133 (operate-on-rectangle 'extract-rectangle-line start end nil) | |
134 (nreverse lines))) | |
135 | |
136 (defvar killed-rectangle nil | |
137 "Rectangle for yank-rectangle to insert.") | |
138 | |
258 | 139 ;;;###autoload |
36 | 140 (defun kill-rectangle (start end) |
141 "Delete rectangle with corners at point and mark; save as last killed one. | |
142 Calling from program, supply two args START and END, buffer positions. | |
242 | 143 But in programs you might prefer to use `delete-extract-rectangle'." |
36 | 144 (interactive "r") |
145 (setq killed-rectangle (delete-extract-rectangle start end))) | |
146 | |
258 | 147 ;;;###autoload |
36 | 148 (defun yank-rectangle () |
149 "Yank the last killed rectangle with upper left corner at point." | |
150 (interactive) | |
151 (insert-rectangle killed-rectangle)) | |
152 | |
258 | 153 ;;;###autoload |
36 | 154 (defun insert-rectangle (rectangle) |
155 "Insert text of RECTANGLE with upper left corner at point. | |
242 | 156 RECTANGLE's first line is inserted at point, its second |
157 line is inserted at a point vertically under point, etc. | |
36 | 158 RECTANGLE should be a list of strings." |
159 (let ((lines rectangle) | |
160 (insertcolumn (current-column)) | |
161 (first t)) | |
162 (while lines | |
163 (or first | |
164 (progn | |
165 (forward-line 1) | |
166 (or (bolp) (insert ?\n)) | |
167 (move-to-column insertcolumn) | |
168 (if (> (current-column) insertcolumn) | |
169 (rectangle-coerce-tab insertcolumn)) | |
170 (if (< (current-column) insertcolumn) | |
171 (indent-to insertcolumn)))) | |
172 (setq first nil) | |
173 (insert (car lines)) | |
174 (setq lines (cdr lines))))) | |
175 | |
258 | 176 ;;;###autoload |
36 | 177 (defun open-rectangle (start end) |
178 "Blank out rectangle with corners at point and mark, shifting text right. | |
179 The text previously in the region is not overwritten by the blanks, | |
180 but insted winds up to the right of the rectangle." | |
181 (interactive "r") | |
182 (operate-on-rectangle 'open-rectangle-line start end nil)) | |
183 | |
184 (defun open-rectangle-line (startpos begextra endextra) | |
185 (let ((column (+ (current-column) begextra endextra))) | |
186 (goto-char startpos) | |
187 (let ((ocol (current-column))) | |
188 (skip-chars-forward " \t") | |
189 (setq column (+ column (- (current-column) ocol)))) | |
190 (delete-region (point) | |
191 (progn (skip-chars-backward " \t") | |
192 (point))) | |
193 (indent-to column))) | |
194 | |
258 | 195 ;;;###autoload |
36 | 196 (defun clear-rectangle (start end) |
197 "Blank out rectangle with corners at point and mark. | |
198 The text previously in the region is overwritten by the blanks. | |
199 When called from a program, requires two args which specify the corners." | |
200 (interactive "r") | |
201 (operate-on-rectangle 'clear-rectangle-line start end t)) | |
202 | |
203 (defun clear-rectangle-line (startpos begextra endextra) | |
204 (skip-chars-forward " \t") | |
205 (let ((column (+ (current-column) endextra))) | |
206 (delete-region (point) | |
207 (progn (goto-char startpos) | |
208 (skip-chars-backward " \t") | |
209 (point))) | |
210 (indent-to column))) | |
211 | |
212 (defun rectangle-coerce-tab (column) | |
213 (let ((aftercol (current-column)) | |
214 (indent-tabs-mode nil)) | |
215 (delete-char -1) | |
216 (indent-to aftercol) | |
217 (backward-char (- aftercol column)))) | |
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
218 |
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
219 ;;; rect.el ends here |