Mercurial > hg > xemacs-beta

comparison lisp/prim/rect.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents b82b59fe008d
children b9518feda344
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
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 Free 21 ;; along with XEmacs; see the file COPYING. If not, write to the
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
23 ;; 02111-1307, USA. 23 ;; Boston, MA 02111-1307, USA.
24 24
25 ;;; Synched up with: FSF 19.34. 25 ;;; Synched up with: FSF 19.30.
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
58 (let ((tem startcol)) 57 (let ((tem startcol))
59 (setq startcol endcol endcol tem))) 58 (setq startcol endcol endcol tem)))
60 (save-excursion 59 (save-excursion
61 (goto-char startlinepos) 60 (goto-char startlinepos)
62 (while (< (point) endlinepos) 61 (while (< (point) endlinepos)
63 (let (startpos begextra endextra) 62 (let (startpos begextra endextra)
64 (move-to-column startcol coerce-tabs) 63 (move-to-column startcol coerce-tabs)
65 (setq begextra (- (current-column) startcol)) 64 (setq begextra (- (current-column) startcol))
66 (setq startpos (point)) 65 (setq startpos (point))
67 (move-to-column endcol coerce-tabs) 66 (move-to-column endcol coerce-tabs)
68 (setq endextra (- endcol (current-column))) 67 (setq endextra (- endcol (current-column)))
69 (if (< begextra 0) 68 (if (< begextra 0)
70 (setq endextra (+ endextra begextra) 69 (setq endextra (+ endextra begextra)
71 begextra 0)) 70 begextra 0))
72 (apply function startpos begextra endextra extra-args)) 71 (apply function startpos begextra endextra extra-args))
73 (forward-line 1))) 72 (forward-line 1)))
74 (- endcol startcol))) 73 (- endcol startcol)))
75 74
76 (defun delete-rectangle-line (startdelpos ignore ignore) 75 (defun delete-rectangle-line (startdelpos ignore ignore)
77 (delete-region startdelpos (point))) 76 (delete-region startdelpos (point)))
78 77
96 (substring line (+ (length line) (- (point) end))))))) 95 (substring line (+ (length line) (- (point) end)))))))
97 (if (or (> begextra 0) (> endextra 0)) 96 (if (or (> begextra 0) (> endextra 0))
98 (setq line (concat (spaces-string begextra) 97 (setq line (concat (spaces-string begextra)
99 line 98 line
100 (spaces-string endextra)))) 99 (spaces-string endextra))))
101 (setcdr lines (cons line (cdr lines))))) ; XEmacs 100 (setcdr lines (cons line (cdr lines)))))
102 101
103 (defconst spaces-strings 102 (defconst spaces-strings
104 (purecopy '["" " " " " " " " " " " " " " " " "])) 103 (purecopy '["" " " " " " " " " " " " " " " " "]))
105 104
106 (defun spaces-string (n) 105 (defun spaces-string (n)
112 (concat val (aref spaces-strings n))))) 111 (concat val (aref spaces-strings n)))))
113 112
114 ;;;###autoload 113 ;;;###autoload
115 (defun delete-rectangle (start end) 114 (defun delete-rectangle (start end)
116 "Delete (don't save) text in rectangle with point and mark as corners. 115 "Delete (don't save) text in rectangle with point and mark as corners.
117 The same range of columns is deleted in each line starting with the line 116 The same range of columns is deleted in each line
118 where the region begins and ending with the line where the region ends." 117 starting with the line where the region begins
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, its second 165 RECTANGLE's first line is inserted at point,
166 line is inserted at a point vertically under point, etc. 166 its second 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)) ; XEmacs 216 (operate-on-rectangle 'string-rectangle-line start end t string))
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
253 (provide 'rect) 260 (provide 'rect)
254 261
255 ;;; rect.el ends here 262 ;;; rect.el ends here