![[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 [Apple XNU] / GNUtools / emacs / lisp|
Return to rect.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 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:
105: (defun delete-rectangle (start end)
106: "Delete (don't save) text in rectangle with point and mark as corners.
107: The same range of columns is deleted in each line
108: starting with the line where the region begins
109: and ending with the line where the region ends."
110: (interactive "r")
111: (operate-on-rectangle 'delete-rectangle-line start end t))
112:
113: (defun delete-extract-rectangle (start end)
114: "Return and delete contents of rectangle with corners at START and END.
115: Value is list of strings, one for each line of the rectangle."
116: (let (lines)
117: (operate-on-rectangle 'delete-extract-rectangle-line
118: start end t)
119: (nreverse lines)))
120:
121: (defun extract-rectangle (start end)
122: "Return contents of rectangle with corners at START and END.
123: Value is list of strings, one for each line of the rectangle."
124: (let (lines)
125: (operate-on-rectangle 'extract-rectangle-line start end nil)
126: (nreverse lines)))
127:
128: (defvar killed-rectangle nil
129: "Rectangle for yank-rectangle to insert.")
130:
131: (defun kill-rectangle (start end)
132: "Delete rectangle with corners at point and mark; save as last killed one.
133: Calling from program, supply two args START and END, buffer positions.
134: But in programs you might prefer to use delete-extract-rectangle."
135: (interactive "r")
136: (setq killed-rectangle (delete-extract-rectangle start end)))
137:
138: (defun yank-rectangle ()
139: "Yank the last killed rectangle with upper left corner at point."
140: (interactive)
141: (insert-rectangle killed-rectangle))
142:
143: (defun insert-rectangle (rectangle)
144: "Insert text of RECTANGLE with upper left corner at point.
145: RECTANGLE's first line is inserted at point,
146: its second line is inserted at a point vertically under point, etc.
147: RECTANGLE should be a list of strings."
148: (let ((lines rectangle)
149: (insertcolumn (current-column))
150: (first t))
151: (while lines
152: (or first
153: (progn
154: (forward-line 1)
155: (or (bolp) (insert ?\n))
156: (move-to-column insertcolumn)
157: (if (> (current-column) insertcolumn)
158: (rectangle-coerce-tab insertcolumn))
159: (if (< (current-column) insertcolumn)
160: (indent-to insertcolumn))))
161: (setq first nil)
162: (insert (car lines))
163: (setq lines (cdr lines)))))
164:
165: (defun open-rectangle (start end)
166: "Blank out rectangle with corners at point and mark, shifting text right.
167: The text previously in the region is not overwritten by the blanks,
168: but insted winds up to the right of the rectangle."
169: (interactive "r")
170: (operate-on-rectangle 'open-rectangle-line start end nil))
171:
172: (defun open-rectangle-line (startpos begextra endextra)
173: (let ((column (+ (current-column) begextra endextra)))
174: (goto-char startpos)
175: (let ((ocol (current-column)))
176: (skip-chars-forward " \t")
177: (setq column (+ column (- (current-column) ocol))))
178: (delete-region (point)
179: (progn (skip-chars-backward " \t")
180: (point)))
181: (indent-to column)))
182:
183: (defun clear-rectangle (start end &optional preserve-position)
184: "Blank out rectangle with corners at point and mark.
185: The text previously in the region is overwritten by the blanks."
186: (interactive "r")
187: (operate-on-rectangle 'clear-rectangle-line start end t))
188:
189: (defun clear-rectangle-line (startpos begextra endextra)
190: (skip-chars-forward " \t")
191: (let ((column (+ (current-column) endextra)))
192: (delete-region (point)
193: (progn (goto-char startpos)
194: (or preserve-position
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.