![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rect.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp|
Return to rect.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp |
1.1 root 1: ;; Rectangle functions for GNU Emacs.
2: ;; Copyright (C) 1985 Richard M. Stallman.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is distributed in the hope that it will be useful,
7: ;; but WITHOUT ANY WARRANTY. No author or distributor
8: ;; accepts responsibility to anyone for the consequences of using it
9: ;; or for whether it serves any particular purpose or works at all,
10: ;; unless he says so in writing. Refer to the GNU Emacs General Public
11: ;; License for full details.
12:
13: ;; Everyone is granted permission to copy, modify and redistribute
14: ;; GNU Emacs, but only under the conditions described in the
15: ;; GNU Emacs General Public License. A copy of this license is
16: ;; supposed to have been given to you along with GNU Emacs so you
17: ;; can know your rights and responsibilities. It should be in a
18: ;; file named COPYING. Among other things, the copyright notice
19: ;; and this notice must be preserved on all copies.
20:
21:
22: (defun operate-on-rectangle (function start end coerce-tabs)
23: "Call FUNCTION for each line of rectangle with corners at START, END.
24: If COERCE-TABS is non-nil, convert multi-column characters
25: that span the starting or ending columns on any line
26: to multiple spaces before calling FUNCTION.
27: FUNCTION is called with three arguments:
28: position of start of segment of this line within the rectangle,
29: number of columns that belong to rectangle but are before that position,
30: number of columns that belong to rectangle but are after point.
31: Point is at the end of the segment of this line within the rectangle."
32: (let (startcol startlinepos endcol endlinepos)
33: (save-excursion
34: (goto-char start)
35: (setq startcol (current-column))
36: (beginning-of-line)
37: (setq startlinepos (point)))
38: (save-excursion
39: (goto-char end)
40: (setq endcol (current-column))
41: (forward-line 1)
42: (setq endlinepos (point-marker)))
43: (if (< endcol startcol)
44: (let ((tem startcol))
45: (setq startcol endcol endcol tem)))
46: (if (/= endcol startcol)
47: (save-excursion
48: (goto-char startlinepos)
49: (while (< (point) endlinepos)
50: (let (startpos begextra endextra)
51: (move-to-column startcol)
52: (and coerce-tabs
53: (> (current-column) startcol)
54: (rectangle-coerce-tab startcol))
55: (setq begextra (- (current-column) startcol))
56: (setq startpos (point))
57: (move-to-column endcol)
58: (if (> (current-column) endcol)
59: (if coerce-tabs
60: (rectangle-coerce-tab endcol)
61: (forward-char -1)))
62: (setq endextra (- endcol (current-column)))
63: (if (< begextra 0)
64: (setq endextra (+ endextra begextra)
65: begextra 0))
66: (funcall function startpos begextra endextra))
67: (forward-line 1))))
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:
106: (defun delete-rectangle (start end)
107: "Delete (don't save) text in rectangle with point and mark as corners.
108: The same range of columns is deleted in each line
109: starting with the line where the region begins
110: and ending with the line where the region ends."
111: (interactive "r")
112: (operate-on-rectangle 'delete-rectangle-line start end t))
113:
114: (defun delete-extract-rectangle (start end)
115: "Return and delete contents of rectangle with corners at START and END.
116: Value is list of strings, one for each line of the rectangle."
117: (let (lines)
118: (operate-on-rectangle 'delete-extract-rectangle-line
119: start end t)
120: (nreverse lines)))
121:
122: (defun extract-rectangle (start end)
123: "Return contents of rectangle with corners at START and END.
124: Value is list of strings, one for each line of the rectangle."
125: (let (lines)
126: (operate-on-rectangle 'extract-rectangle-line start end nil)
127: (nreverse lines)))
128:
129: (defvar killed-rectangle nil
130: "Rectangle for yank-rectangle to insert.")
131:
132: (defun kill-rectangle (start end)
133: "Delete rectangle with corners at point and mark; save as last killed one.
134: Calling from program, supply two args START and END, buffer positions.
135: But in programs you might prefer to use delete-extract-rectangle."
136: (interactive "r")
137: (setq killed-rectangle (delete-extract-rectangle start end)))
138:
139: (defun yank-rectangle ()
140: "Yank the last killed rectangle with upper left corner at point."
141: (interactive)
142: (insert-rectangle killed-rectangle))
143:
144: (defun insert-rectangle (rectangle)
145: "Insert text of RECTANGLE with upper left corner at point.
146: RECTANGLE's first line is inserted at point,
147: its second line is inserted at a point vertically under point, etc.
148: RECTANGLE should be a list of strings."
149: (let ((lines rectangle)
150: (insertcolumn (current-column))
151: (first t))
152: (while lines
153: (or first
154: (progn
155: (forward-line 1)
156: (or (bolp) (insert ?\n))
157: (move-to-column insertcolumn)
158: (if (> (current-column) insertcolumn)
159: (rectangle-coerce-tab insertcolumn))
160: (if (< (current-column) insertcolumn)
161: (indent-to insertcolumn))))
162: (setq first nil)
163: (insert (car lines))
164: (setq lines (cdr lines)))))
165:
166: (defun open-rectangle (start end)
167: "Blank out rectangle with corners at point and mark, shifting text right.
168: The text previously in the region is not overwritten by the blanks,
169: but insted winds up to the right of the rectangle."
170: (interactive "r")
171: (operate-on-rectangle 'open-rectangle-line start end nil))
172:
173: (defun open-rectangle-line (startpos begextra endextra)
174: (let ((column (+ (current-column) begextra endextra)))
175: (goto-char startpos)
176: (let ((ocol (current-column)))
177: (skip-chars-forward " \t")
178: (setq column (+ column (- (current-column) ocol))))
179: (delete-region (point)
180: (progn (skip-chars-backward " \t")
181: (point)))
182: (indent-to column)))
183:
184: (defun clear-rectangle (start end)
185: "Blank out rectangle with corners at point and mark.
186: The text previously in the region is overwritten by the blanks."
187: (interactive "r")
188: (operate-on-rectangle 'clear-rectangle-line start end t))
189:
190: (defun clear-rectangle-line (startpos begextra endextra)
191: (skip-chars-forward " \t")
192: (let ((column (+ (current-column) endextra)))
193: (delete-region (point)
194: (progn (goto-char startpos)
195: (skip-chars-backward " \t")
196: (point)))
197: (indent-to column)))
198:
199: (defun rectangle-coerce-tab (column)
200: (let ((aftercol (current-column))
201: (indent-tabs-mode nil))
202: (delete-char -1)
203: (indent-to aftercol)
204: (backward-char (- aftercol column))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.