428
+ − 1 ;;; rect.el --- rectangle functions for XEmacs.
+ − 2
442
+ − 3 ;; Copyright (C) 1985-2000 Free Software Foundation, Inc.
428
+ − 4
442
+ − 5 ;; Maintainer: Didier Verna <didier@xemacs.org>
428
+ − 6 ;; Keywords: internal
+ − 7
+ − 8 ;; This file is part of XEmacs.
+ − 9
+ − 10 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 11 ;; under the terms of the GNU General Public License as published by
+ − 12 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 13 ;; any later version.
+ − 14
+ − 15 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 18 ;; General Public License for more details.
+ − 19
+ − 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
+ − 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ − 23 ;; 02111-1307, USA.
+ − 24
+ − 25 ;;; Synched up with: to be incorporated in a forthcoming GNU Emacs
+ − 26
+ − 27 ;;; Commentary:
+ − 28
+ − 29 ;; This package provides the operations on rectangles that are documented
+ − 30 ;; in the XEmacs Reference Manual.
+ − 31
440
+ − 32 ;; #### NOTE: this file has been almost completely rewritten by Didier Verna
442
+ − 33 ;; <didier@xemacs.org>, Jul 99. The purpose of this rewrite is to be less
428
+ − 34 ;; intrusive and fill lines with whitespaces only when needed. A few functions
+ − 35 ;; are untouched though, as noted above their definition.
+ − 36
+ − 37
+ − 38 ;;; Code:
+ − 39
440
+ − 40 ;; #### NOTE: this function is untouched, but not used anymore.
428
+ − 41 ;; `apply-on-rectangle' is used instead. It's still there because it's
+ − 42 ;; documented so people might use it in their code, so I've decided not to
+ − 43 ;; touch it. --dv
+ − 44 ;; XEmacs: extra-args
+ − 45 (defun operate-on-rectangle (function start end coerce-tabs &rest extra-args)
+ − 46 "Call FUNCTION for each line of rectangle with corners at START, END.
+ − 47 If COERCE-TABS is non-nil, convert multi-column characters
+ − 48 that span the starting or ending columns on any line
+ − 49 to multiple spaces before calling FUNCTION.
+ − 50 FUNCTION is called with three arguments:
+ − 51 position of start of segment of this line within the rectangle,
+ − 52 number of columns that belong to rectangle but are before that position,
+ − 53 number of columns that belong to rectangle but are after point.
+ − 54 Point is at the end of the segment of this line within the rectangle."
+ − 55 (let (startcol startlinepos endcol endlinepos)
+ − 56 (save-excursion
+ − 57 (goto-char start)
+ − 58 (setq startcol (current-column))
+ − 59 (beginning-of-line)
+ − 60 (setq startlinepos (point)))
+ − 61 (save-excursion
+ − 62 (goto-char end)
+ − 63 (setq endcol (current-column))
+ − 64 (forward-line 1)
+ − 65 (setq endlinepos (point-marker)))
+ − 66 (if (< endcol startcol)
+ − 67 ;; XEmacs
+ − 68 (let ((tem startcol))
+ − 69 (setq startcol endcol endcol tem)))
+ − 70 (save-excursion
+ − 71 (goto-char startlinepos)
+ − 72 (while (< (point) endlinepos)
+ − 73 (let (startpos begextra endextra)
+ − 74 (move-to-column startcol coerce-tabs)
+ − 75 (setq begextra (- (current-column) startcol))
+ − 76 (setq startpos (point))
+ − 77 (move-to-column endcol coerce-tabs)
+ − 78 (setq endextra (- endcol (current-column)))
+ − 79 (if (< begextra 0)
+ − 80 (setq endextra (+ endextra begextra)
+ − 81 begextra 0))
+ − 82 (if (< endextra 0) (setq endextra 0))
+ − 83 (apply function startpos begextra endextra extra-args))
+ − 84 (forward-line 1)))
+ − 85 (- endcol startcol)))
+ − 86
+ − 87 ;; The replacement for `operate-on-rectangle' -- dv
+ − 88 (defun apply-on-rectangle (function start end &rest args)
+ − 89 "Call FUNCTION for each line of rectangle with corners at START and END.
+ − 90 FUNCTION is called with two arguments: the start and end columns of the
+ − 91 rectangle, plus ARGS extra arguments. Point is at the beginning of line
+ − 92 when the function is called."
+ − 93 (let (startcol startpt endcol endpt)
+ − 94 (save-excursion
+ − 95 (goto-char start)
+ − 96 (setq startcol (current-column))
+ − 97 (beginning-of-line)
+ − 98 (setq startpt (point))
+ − 99 (goto-char end)
+ − 100 (setq endcol (current-column))
+ − 101 (forward-line 1)
+ − 102 (setq endpt (point-marker))
+ − 103 ;; ensure the start column is the left one.
+ − 104 (if (< endcol startcol)
+ − 105 (let ((col startcol))
+ − 106 (setq startcol endcol endcol col)))
+ − 107 ;; start looping over lines
+ − 108 (goto-char startpt)
+ − 109 (while (< (point) endpt)
+ − 110 (apply function startcol endcol args)
+ − 111 (forward-line 1)))
+ − 112 ))
+ − 113
+ − 114
442
+ − 115 (defun delete-rectangle-line (startcol endcol fill)
+ − 116 (let ((pt (point-at-eol)))
+ − 117 (when (= (move-to-column startcol (or fill 'coerce)) startcol)
+ − 118 (if (and (not fill) (<= pt endcol))
+ − 119 (delete-region (point) pt)
+ − 120 ;; else
+ − 121 (setq pt (point))
+ − 122 (move-to-column endcol t)
+ − 123 (delete-region pt (point))))
+ − 124 ))
428
+ − 125
+ − 126 ;;;###autoload
+ − 127 (defun delete-rectangle (start end &optional fill)
+ − 128 "Delete the text in the region-rectangle without saving it.
+ − 129 The same range of columns is deleted in each line starting with the line
+ − 130 where the region begins and ending with the line where the region ends.
+ − 131
+ − 132 When called from a program, the rectangle's corners are START and END.
+ − 133 With a prefix (or FILL) argument, also fill lines where nothing has to be
+ − 134 deleted."
+ − 135 (interactive "*r\nP")
+ − 136 (apply-on-rectangle 'delete-rectangle-line start end fill))
+ − 137
+ − 138
442
+ − 139 ;; I love ascii art ;-)
+ − 140 (defconst spaces-strings '[""
+ − 141 " "
+ − 142 " "
+ − 143 " "
+ − 144 " "
+ − 145 " "
+ − 146 " "
+ − 147 " "
+ − 148 " "])
428
+ − 149
442
+ − 150 ;; This function is untouched --dv
+ − 151 (defun spaces-string (n)
+ − 152 (if (<= n 8) (aref spaces-strings n)
+ − 153 (let ((val ""))
+ − 154 (while (> n 8)
+ − 155 (setq val (concat " " val)
+ − 156 n (- n 8)))
+ − 157 (concat val (aref spaces-strings n)))))
+ − 158
428
+ − 159
+ − 160 (defun delete-extract-rectangle-line (startcol endcol lines fill)
+ − 161 (let ((pt (point-at-eol)))
+ − 162 (if (< (move-to-column startcol (or fill 'coerce)) startcol)
+ − 163 (setcdr lines (cons (spaces-string (- endcol startcol))
+ − 164 (cdr lines)))
+ − 165 ;; else
+ − 166 (setq pt (point))
+ − 167 (move-to-column endcol t)
+ − 168 (setcdr lines (cons (buffer-substring pt (point)) (cdr lines)))
+ − 169 (delete-region pt (point)))
+ − 170 ))
+ − 171
+ − 172 ;;;###autoload
442
+ − 173 (defun delete-extract-rectangle (start end &optional fill)
+ − 174 "Delete the contents of the rectangle with corners at START and END, and
+ − 175 return it as a list of strings, one for each line of the rectangle.
+ − 176
+ − 177 With an optional FILL argument, also fill lines where nothing has to be
+ − 178 deleted."
428
+ − 179 (let ((lines (list nil)))
442
+ − 180 (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill)
428
+ − 181 (nreverse (cdr lines))))
+ − 182
442
+ − 183
440
+ − 184 ;; #### NOTE: this is actually the only function that needs to do complicated
428
+ − 185 ;; stuff like what's happening in `operate-on-rectangle', because the buffer
+ − 186 ;; might be read-only. --dv
+ − 187 (defun extract-rectangle-line (startcol endcol lines)
+ − 188 (let (start end begextra endextra line)
+ − 189 (move-to-column startcol)
+ − 190 (setq start (point)
+ − 191 begextra (- (current-column) startcol))
+ − 192 (move-to-column endcol)
+ − 193 (setq end (point)
+ − 194 endextra (- endcol (current-column)))
+ − 195 (setq line (buffer-substring start (point)))
+ − 196 (if (< begextra 0)
+ − 197 (setq endextra (+ endextra begextra)
+ − 198 begextra 0))
+ − 199 (if (< endextra 0)
+ − 200 (setq endextra 0))
+ − 201 (goto-char start)
+ − 202 (while (search-forward "\t" end t)
+ − 203 (let ((width (- (current-column)
446
+ − 204 (save-excursion (backward-char 1)
428
+ − 205 (current-column)))))
+ − 206 (setq line (concat (substring line 0 (- (point) end 1))
+ − 207 (spaces-string width)
+ − 208 (substring line (+ (length line)
+ − 209 (- (point) end)))))))
+ − 210 (if (or (> begextra 0) (> endextra 0))
+ − 211 (setq line (concat (spaces-string begextra)
+ − 212 line
+ − 213 (spaces-string endextra))))
+ − 214 (setcdr lines (cons line (cdr lines)))))
+ − 215
442
+ − 216 ;;;###autoload
+ − 217 (defun extract-rectangle (start end)
+ − 218 "Return the contents of the rectangle with corners at START and END,
+ − 219 as a list of strings, one for each line of the rectangle."
+ − 220 (let ((lines (list nil)))
+ − 221 (apply-on-rectangle 'extract-rectangle-line start end lines)
+ − 222 (nreverse (cdr lines))))
+ − 223
+ − 224
+ − 225 ;;;###autoload
+ − 226 (defvar killed-rectangle nil
+ − 227 "Rectangle for `yank-rectangle' to insert.")
+ − 228
+ − 229 ;;;###autoload
+ − 230 (defun kill-rectangle (start end &optional fill)
+ − 231 "Delete the region-rectangle and save it as the last killed one.
+ − 232 You might prefer to use `delete-extract-rectangle' from a program.
+ − 233
+ − 234 When called from a program, the rectangle's corners are START and END.
+ − 235 With a prefix (or FILL) argument, also fill lines where nothing has to be
+ − 236 deleted."
+ − 237 (interactive "*r\nP")
+ − 238 (when buffer-read-only
+ − 239 (setq killed-rectangle (extract-rectangle start end))
+ − 240 (barf-if-buffer-read-only))
+ − 241 (setq killed-rectangle (delete-extract-rectangle start end fill)))
+ − 242
428
+ − 243 ;; This function is untouched --dv
+ − 244 ;;;###autoload
+ − 245 (defun yank-rectangle ()
+ − 246 "Yank the last killed rectangle with upper left corner at point."
+ − 247 (interactive "*")
+ − 248 (insert-rectangle killed-rectangle))
+ − 249
442
+ − 250
428
+ − 251 ;; This function is untouched --dv
+ − 252 ;;;###autoload
+ − 253 (defun insert-rectangle (rectangle)
+ − 254 "Insert text of RECTANGLE with upper left corner at point.
+ − 255 RECTANGLE's first line is inserted at point, its second
+ − 256 line is inserted at a point vertically under point, etc.
+ − 257 RECTANGLE should be a list of strings.
+ − 258 After this command, the mark is at the upper left corner
+ − 259 and point is at the lower right corner."
+ − 260 (let ((lines rectangle)
+ − 261 (insertcolumn (current-column))
+ − 262 (first t))
+ − 263 (push-mark)
+ − 264 (while lines
+ − 265 (or first
+ − 266 (progn
+ − 267 (forward-line 1)
+ − 268 (or (bolp) (insert ?\n))
+ − 269 (move-to-column insertcolumn t)))
+ − 270 (setq first nil)
+ − 271 (insert (car lines))
+ − 272 (setq lines (cdr lines)))))
+ − 273
442
+ − 274
+ − 275 (defun open-rectangle-line (startcol endcol fill)
+ − 276 (when (= (move-to-column startcol (or fill 'coerce)) startcol)
+ − 277 (unless (and (not fill)
+ − 278 (= (point) (point-at-eol)))
+ − 279 (indent-to endcol))))
+ − 280
428
+ − 281 ;;;###autoload
+ − 282 (defun open-rectangle (start end &optional fill)
+ − 283 "Blank out the region-rectangle, shifting text right.
+ − 284
+ − 285 When called from a program, the rectangle's corners are START and END.
+ − 286 With a prefix (or FILL) argument, fill with blanks even if there is no text
+ − 287 on the right side of the rectangle."
+ − 288 (interactive "*r\nP")
+ − 289 (apply-on-rectangle 'open-rectangle-line start end fill)
+ − 290 (goto-char start))
+ − 291
442
+ − 292
+ − 293 (defun string-rectangle-line (startcol endcol string delete)
+ − 294 (move-to-column startcol t)
+ − 295 (if delete
+ − 296 (delete-rectangle-line startcol endcol nil))
+ − 297 (insert string))
428
+ − 298
+ − 299 ;;;###autoload
+ − 300 (defun string-rectangle (start end string)
+ − 301 "Insert STRING on each line of the region-rectangle, shifting text right.
442
+ − 302 The left edge of the rectangle specifies the column for insertion.
+ − 303
+ − 304 If `pending-delete-mode' is active the string replace the region.
+ − 305 Otherwise this command does not delete or overwrite any existing text.
428
+ − 306
+ − 307 When called from a program, the rectangle's corners are START and END."
+ − 308 (interactive "*r\nsString rectangle: ")
442
+ − 309 (defvar pending-delete-mode)
+ − 310 (apply-on-rectangle 'string-rectangle-line start end string
+ − 311 (and (boundp 'pending-delete-mode) pending-delete-mode)))
428
+ − 312
686
+ − 313 ;;;###autoload
442
+ − 314 (defun replace-rectangle (start end string)
+ − 315 "Like `string-rectangle', but unconditionally replace the original region,
+ − 316 as if `pending-delete-mode' were active."
+ − 317 (interactive "*r\nsString rectangle: ")
+ − 318 (apply-on-rectangle 'string-rectangle-line start end string t))
428
+ − 319
+ − 320
+ − 321 (defun clear-rectangle-line (startcol endcol fill)
+ − 322 (let ((pt (point-at-eol))
+ − 323 spaces)
+ − 324 (when (= (move-to-column startcol (or fill 'coerce)) startcol)
+ − 325 (if (and (not fill)
+ − 326 (<= (save-excursion (goto-char pt) (current-column)) endcol))
+ − 327 (delete-region (point) pt)
+ − 328 ;; else
+ − 329 (setq pt (point))
+ − 330 (move-to-column endcol t)
+ − 331 (setq spaces (- (point) pt))
+ − 332 (delete-region pt (point))
+ − 333 (indent-to (+ (current-column) spaces))))
+ − 334 ))
+ − 335
442
+ − 336 ;;;###autoload
+ − 337 (defun clear-rectangle (start end &optional fill)
+ − 338 "Blank out the region-rectangle.
+ − 339 The text previously in the region is overwritten with blanks.
+ − 340
+ − 341 When called from a program, the rectangle's corners are START and END.
+ − 342 With a prefix (or FILL) argument, also fill with blanks the parts of the
+ − 343 rectangle which were empty."
+ − 344 (interactive "*r\nP")
+ − 345 (apply-on-rectangle 'clear-rectangle-line start end fill))
+ − 346
+ − 347
428
+ − 348 (provide 'rect)
+ − 349
+ − 350 ;;; rect.el ends here