Mercurial > hg > xemacs-beta

comparison lisp/prim/rect.el @ 72:b9518feda344 r20-0b31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b31
author cvs
date Mon, 13 Aug 2007 09:03:46 +0200
parents 131b0175ea99
children 28f395d8dc7a
comparison
equal deleted inserted replaced
71:bae944334fa4 72:b9518feda344
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details. 18 ;; General Public License for more details.
19 19
20 ;; You should have received a copy of the GNU General Public License 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 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Free Software Foundation, 59 Temple Place - Suite 330, 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; Boston, MA 02111-1307, USA. 23 ;; 02111-1307, USA.
24 24
25 ;;; Synched up with: FSF 19.30. 25 ;;; Synched up with: FSF 19.34.
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28 28
29 ;; This package provides the operations on rectangles that are ocumented 29 ;; This package provides the operations on rectangles that are ocumented
30 ;; in the XEmacs Reference Manual. 30 ;; in the XEmacs Reference Manual.
52 (goto-char end) 52 (goto-char end)
53 (setq endcol (current-column)) 53 (setq endcol (current-column))
54 (forward-line 1) 54 (forward-line 1)
55 (setq endlinepos (point-marker))) 55 (setq endlinepos (point-marker)))
56 (if (< endcol startcol) 56 (if (< endcol startcol)
57 ;; XEmacs
57 (let ((tem startcol)) 58 (let ((tem startcol))
58 (setq startcol endcol endcol tem))) 59 (setq startcol endcol endcol tem)))
59 (save-excursion 60 (save-excursion
60 (goto-char startlinepos) 61 (goto-char startlinepos)
61 (while (< (point) endlinepos) 62 (while (< (point) endlinepos)
62 (let (startpos begextra endextra) 63 (let (startpos begextra endextra)
63 (move-to-column startcol coerce-tabs) 64 (move-to-column startcol coerce-tabs)
64 (setq begextra (- (current-column) startcol)) 65 (setq begextra (- (current-column) startcol))
65 (setq startpos (point)) 66 (setq startpos (point))
66 (move-to-column endcol coerce-tabs) 67 (move-to-column endcol coerce-tabs)
67 (setq endextra (- endcol (current-column))) 68 (setq endextra (- endcol (current-column)))
68 (if (< begextra 0) 69 (if (< begextra 0)
69 (setq endextra (+ endextra begextra) 70 (setq endextra (+ endextra begextra)
70 begextra 0)) 71 begextra 0))
71 (apply function startpos begextra endextra extra-args)) 72 (apply function startpos begextra endextra extra-args))
72 (forward-line 1))) 73 (forward-line 1)))
73 (- endcol startcol))) 74 (- endcol startcol)))
74 75
75 (defun delete-rectangle-line (startdelpos ignore ignore) 76 (defun delete-rectangle-line (startdelpos ignore ignore)
76 (delete-region startdelpos (point))) 77 (delete-region startdelpos (point)))
77 78
95 (substring line (+ (length line) (- (point) end))))))) 96 (substring line (+ (length line) (- (point) end)))))))
96 (if (or (> begextra 0) (> endextra 0)) 97 (if (or (> begextra 0) (> endextra 0))
97 (setq line (concat (spaces-string begextra) 98 (setq line (concat (spaces-string begextra)
98 line 99 line
99 (spaces-string endextra)))) 100 (spaces-string endextra))))
100 (setcdr lines (cons line (cdr lines))))) 101 (setcdr lines (cons line (cdr lines))))) ; XEmacs
101 102
102 (defconst spaces-strings 103 (defconst spaces-strings
103 (purecopy '["" " " " " " " " " " " " " " " " "])) 104 (purecopy '["" " " " " " " " " " " " " " " " "]))
104 105
105 (defun spaces-string (n) 106 (defun spaces-string (n)
111 (concat val (aref spaces-strings n))))) 112 (concat val (aref spaces-strings n)))))
112 113
113 ;;;###autoload 114 ;;;###autoload
114 (defun delete-rectangle (start end) 115 (defun delete-rectangle (start end)
115 "Delete (don't save) text in rectangle with point and mark as corners. 116 "Delete (don't save) text in rectangle with point and mark as corners.
116 The same range of columns is deleted in each line 117 The same range of columns is deleted in each line starting with the line
117 starting with the line where the region begins 118 where the region begins and ending with the line where the region ends."
118 and ending with the line where the region ends."
119 (interactive "r") 119 (interactive "r")
120 (operate-on-rectangle 'delete-rectangle-line start end t)) 120 (operate-on-rectangle 'delete-rectangle-line start end t))
121 121
122 ;;;###autoload 122 ;;;###autoload
123 (defun delete-extract-rectangle (start end) 123 (defun delete-extract-rectangle (start end)
160 (insert-rectangle killed-rectangle)) 160 (insert-rectangle killed-rectangle))
161 161
162 ;;;###autoload 162 ;;;###autoload
163 (defun insert-rectangle (rectangle) 163 (defun insert-rectangle (rectangle)
164 "Insert text of RECTANGLE with upper left corner at point. 164 "Insert text of RECTANGLE with upper left corner at point.
165 RECTANGLE's first line is inserted at point, 165 RECTANGLE's first line is inserted at point, its second
166 its second line is inserted at a point vertically under point, etc. 166 line is inserted at a point vertically under point, etc.
167 RECTANGLE should be a list of strings. 167 RECTANGLE should be a list of strings.
168 After this command, the mark is at the upper left corner 168 After this command, the mark is at the upper left corner
169 and point is at the lower right corner." 169 and point is at the lower right corner."
170 (let ((lines rectangle) 170 (let ((lines rectangle)
171 (insertcolumn (current-column)) 171 (insertcolumn (current-column))
211 The left edge of the rectangle specifies the column for insertion. 211 The left edge of the rectangle specifies the column for insertion.
212 This command does not delete or overwrite any existing text. 212 This command does not delete or overwrite any existing text.
213 213
214 Called from a program, takes three args; START, END and STRING." 214 Called from a program, takes three args; START, END and STRING."
215 (interactive "r\nsString rectangle: ") 215 (interactive "r\nsString rectangle: ")
216 (operate-on-rectangle 'string-rectangle-line start end t string)) 216 (operate-on-rectangle 'string-rectangle-line start end t string)) ; XEmacs
217 217
218 ;; XEmacs: add string arg 218 ;; XEmacs: add string arg
219 (defun string-rectangle-line (startpos begextra endextra string) 219 (defun string-rectangle-line (startpos begextra endextra string)
220 (let (whitespace) 220 (let (whitespace)
221 (goto-char startpos) 221 (goto-char startpos)
248 (skip-chars-backward " \t") 248 (skip-chars-backward " \t")
249 (point))) 249 (point)))
250 ;; Reindent out to same column that we were at. 250 ;; Reindent out to same column that we were at.
251 (indent-to column))) 251 (indent-to column)))
252 252
253 ;(defun rectangle-coerce-tab (column)
254 ; (let ((aftercol (current-column))
255 ; (indent-tabs-mode nil))
256 ; (delete-char -1)
257 ; (indent-to aftercol)
258 ; (backward-char (- aftercol column))))
259
260 (provide 'rect) 253 (provide 'rect)
261 254
262 ;;; rect.el ends here 255 ;;; rect.el ends here