rect.el 13.1 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1 2
;;; rect.el --- rectangle functions for GNU Emacs.

3
;; Copyright (C) 1985, 1999 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

5
;; Maintainer: Didier Verna <verna@inf.enst.fr>
Eric S. Raymond's avatar
Eric S. Raymond committed
6
;; Keywords: internal
Eric S. Raymond's avatar
Eric S. Raymond committed
7

Joseph Arceneaux's avatar
Joseph Arceneaux committed
8 9 10 11
;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
Eric S. Raymond's avatar
Eric S. Raymond committed
12
;; the Free Software Foundation; either version 2, or (at your option)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
13 14 15 16 17 18 19 20
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
Erik Naggum's avatar
Erik Naggum committed
21 22 23
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
24

25 26
;;; Commentary:

27
;; This package provides the operations on rectangles that are documented
28 29
;; in the Emacs manual.

30 31 32 33 34 35
;; ### NOTE: this file has been almost completely rewritten by Didier Verna
;; <verna@inf.enst.fr> in July 1999. The purpose of this rewrite is to be less
;; intrusive and fill lines with whitespaces only when needed. A few functions
;; are untouched though, as noted above their definition.


Eric S. Raymond's avatar
Eric S. Raymond committed
36
;;; Code:
Joseph Arceneaux's avatar
Joseph Arceneaux committed
37

38
;;;###autoload
39
(defun move-to-column-force (column &optional flag)
40 41
  "Move point to column COLUMN rigidly in the current line.
If COLUMN is within a multi-column character, replace it by
42 43 44 45 46
spaces and tab.

As for `move-to-column', passing anything but nil or t in FLAG will move to
the desired column only if the line is long enough."
  (let ((col (move-to-column column (or flag t))))
47 48 49 50 51 52 53 54 55
    (if (> col column)
	(let (pos)
	  (delete-char -1)
	  (insert-char ?  (- column (current-column)))
	  (setq pos (point))
	  (indent-to col)
	  (goto-char pos)))
    column))

56
;; not used any more --dv
57 58 59 60
;; extract-rectangle-line stores lines into this list
;; to accumulate them for extract-rectangle and delete-extract-rectangle.
(defvar operate-on-rectangle-lines)

61 62
;; ### NOTE: this function is untouched, but not used anymore appart in
;; `delete-whitespace-rectangle'. `apply-on-rectangle' is used instead. --dv
Joseph Arceneaux's avatar
Joseph Arceneaux committed
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
(defun operate-on-rectangle (function start end coerce-tabs)
  "Call FUNCTION for each line of rectangle with corners at START, END.
If COERCE-TABS is non-nil, convert multi-column characters
that span the starting or ending columns on any line
to multiple spaces before calling FUNCTION.
FUNCTION is called with three arguments:
 position of start of segment of this line within the rectangle,
 number of columns that belong to rectangle but are before that position,
 number of columns that belong to rectangle but are after point.
Point is at the end of the segment of this line within the rectangle."
  (let (startcol startlinepos endcol endlinepos)
    (save-excursion
     (goto-char start)
     (setq startcol (current-column))
     (beginning-of-line)
     (setq startlinepos (point)))
    (save-excursion
     (goto-char end)
     (setq endcol (current-column))
     (forward-line 1)
     (setq endlinepos (point-marker)))
    (if (< endcol startcol)
85
	(setq startcol (prog1 endcol (setq endcol startcol))))
86 87 88 89
    (save-excursion
     (goto-char startlinepos)
     (while (< (point) endlinepos)
       (let (startpos begextra endextra)
90 91 92
	 (if coerce-tabs
	     (move-to-column-force startcol)
	   (move-to-column startcol))
93 94
	 (setq begextra (- (current-column) startcol))
	 (setq startpos (point))
95 96 97
	 (if coerce-tabs
	     (move-to-column-force endcol)
	   (move-to-column endcol))
98 99 100 101
	 ;; If we overshot, move back one character
	 ;; so that endextra will be positive.
	 (if (and (not coerce-tabs) (> (current-column) endcol))
	     (backward-char 1))
102 103 104 105 106 107
	 (setq endextra (- endcol (current-column)))
	 (if (< begextra 0)
	     (setq endextra (+ endextra begextra)
		   begextra 0))
	 (funcall function startpos begextra endextra))
       (forward-line 1)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
108 109
    (- endcol startcol)))

110 111 112 113
;; The replacement for `operate-on-rectangle' -- dv
(defun apply-on-rectangle (function start end &rest args)
  "Call FUNCTION for each line of rectangle with corners at START, END.
FUNCTION is called with two arguments: the start and end columns of the
114
rectangle, plus ARGS extra arguments.  Point is at the beginning of line when
115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
the function is called."
  (let (startcol startpt endcol endpt)
    (save-excursion
      (goto-char start)
      (setq startcol (current-column))
      (beginning-of-line)
      (setq startpt (point))
      (goto-char end)
      (setq endcol (current-column))
      (forward-line 1)
      (setq endpt (point-marker))
      ;; ensure the start column is the left one.
      (if (< endcol startcol)
	  (let ((col startcol))
	    (setq startcol endcol endcol col)))
      ;; start looping over lines
      (goto-char startpt)
      (while (< (point) endpt)
	(apply function startcol endcol args)
	(forward-line 1)))
    ))

(defun delete-rectangle-line (startcol endcol fill)
138
  (let ((pt (line-end-position)))
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
    (when (= (move-to-column-force startcol (or fill 'coerce)) startcol)
      (if (and (not fill) (<= pt endcol))
	  (delete-region (point) pt)
	;; else
	(setq pt (point))
	(move-to-column-force endcol)
	(delete-region pt (point))))
    ))

(defun delete-extract-rectangle-line (startcol endcol lines fill)
  (let ((pt (point-at-eol)))
    (if (< (move-to-column-force startcol (or fill 'coerce)) startcol)
	(setcdr lines (cons (spaces-string (- endcol startcol))
			    (cdr lines)))
      ;; else
      (setq pt (point))
      (move-to-column-force endcol)
      (setcdr lines (cons (buffer-substring pt (point)) (cdr lines)))
      (delete-region pt (point)))
    ))

;; ### NOTE: this is actually the only function that needs to do complicated
;; stuff like what's happening in `operate-on-rectangle', because the buffer
;; might be read-only. --dv
(defun extract-rectangle-line (startcol endcol lines)
  (let (start end begextra endextra line)
    (move-to-column startcol)
    (setq start (point)
	  begextra (- (current-column) startcol))
    (move-to-column endcol)
    (setq end (point)
	  endextra (- endcol (current-column)))
    (setq line (buffer-substring start (point)))
    (if (< begextra 0)
	(setq endextra (+ endextra begextra)
	      begextra 0))
    (if (< endextra 0)
	(setq endextra 0))
    (goto-char start)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
178 179 180 181 182 183
    (while (search-forward "\t" end t)
      (let ((width (- (current-column)
		      (save-excursion (forward-char -1)
				      (current-column)))))
	(setq line (concat (substring line 0 (- (point) end 1))
			   (spaces-string width)
184 185
			   (substring line (+ (length line)
					      (- (point) end)))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
186 187 188 189
    (if (or (> begextra 0) (> endextra 0))
	(setq line (concat (spaces-string begextra)
			   line
			   (spaces-string endextra))))
190
    (setcdr lines (cons line (cdr lines)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
191 192 193 194

(defconst spaces-strings
  '["" " " "  " "   " "    " "     " "      " "       " "        "])

195
;; this one is untouched --dv
Joseph Arceneaux's avatar
Joseph Arceneaux committed
196 197 198 199 200 201 202 203
(defun spaces-string (n)
  (if (<= n 8) (aref spaces-strings n)
    (let ((val ""))
      (while (> n 8)
	(setq val (concat "        " val)
	      n (- n 8)))
      (concat val (aref spaces-strings n)))))
    
Jim Blandy's avatar
Jim Blandy committed
204
;;;###autoload
205
(defun delete-rectangle (start end &optional fill)
206 207 208 209 210 211 212 213 214
  "Delete (don't save) text in the region-rectangle.
The same range of columns is deleted in each line starting with the
line where the region begins and ending with the line where the region
ends.

When called from a program the rectangle's corners are START and END.
With a prefix (or a FILL) argument, also fill lines where nothing has
to be deleted."
  (interactive "*r\nP")
215
  (apply-on-rectangle 'delete-rectangle-line start end fill))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
216

Jim Blandy's avatar
Jim Blandy committed
217
;;;###autoload
218
(defun delete-extract-rectangle (start end &optional fill)
219 220
  "Delete the contents of the region-rectangle.
Return it as a list of strings, one for each line of the rectangle.
221

222
When called from a program the rectangle's corners are START and END.
223 224 225 226 227
With an optional FILL argument, also fill lines where nothing has to be
deleted."
  (let ((lines (list nil)))
    (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill)
    (nreverse (cdr lines))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
228

Jim Blandy's avatar
Jim Blandy committed
229
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
230
(defun extract-rectangle (start end)
231 232
  "Return the contents of the rectangle with corners at START and END.
Return it as a list of strings, one for each line of the rectangle."
233 234 235
  (let ((lines (list nil)))
    (apply-on-rectangle 'extract-rectangle-line start end lines)
    (nreverse (cdr lines))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
236 237

(defvar killed-rectangle nil
238
  "Rectangle for `yank-rectangle' to insert.")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
239

Jim Blandy's avatar
Jim Blandy committed
240
;;;###autoload
241
(defun kill-rectangle (start end &optional fill)
242 243 244 245
  "Delete the region-rectangle and save it as the last killed one.

When called from a program the rectangle's corners are START and END.
You might prefer to use `delete-extract-rectangle' from a program.
246 247 248

With a prefix (or a FILL) argument, also fill lines where nothing has to be
deleted."
249
  (interactive "*r\nP")
250 251 252 253 254 255
  (when buffer-read-only
    (setq killed-rectangle (extract-rectangle start end))
    (barf-if-buffer-read-only))
  (setq killed-rectangle (delete-extract-rectangle start end fill)))

;; this one is untouched --dv
Jim Blandy's avatar
Jim Blandy committed
256
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
257 258
(defun yank-rectangle ()
  "Yank the last killed rectangle with upper left corner at point."
259
  (interactive "*")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
260 261
  (insert-rectangle killed-rectangle))

262
;; this one is untoutched --dv
Jim Blandy's avatar
Jim Blandy committed
263
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
264 265
(defun insert-rectangle (rectangle)
  "Insert text of RECTANGLE with upper left corner at point.
266 267
RECTANGLE's first line is inserted at point, its second
line is inserted at a point vertically under point, etc.
268 269 270
RECTANGLE should be a list of strings.
After this command, the mark is at the upper left corner
and point is at the lower right corner."
Joseph Arceneaux's avatar
Joseph Arceneaux committed
271 272 273
  (let ((lines rectangle)
	(insertcolumn (current-column))
	(first t))
274
    (push-mark)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
275 276 277 278 279
    (while lines
      (or first
	  (progn
	   (forward-line 1)
	   (or (bolp) (insert ?\n))
280
	   (move-to-column-force insertcolumn)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
281 282 283 284
      (setq first nil)
      (insert (car lines))
      (setq lines (cdr lines)))))

Jim Blandy's avatar
Jim Blandy committed
285
;;;###autoload
286
(defun open-rectangle (start end &optional fill)
287 288 289 290
  "Blank out the region-rectangle, shifting text right.

The text previously in the region is not overwritten by the blanks,
but instead winds up to the right of the rectangle.
291

292
When called from a program the rectangle's corners are START and END.
293 294
With a prefix (or a FILL) argument, fill with blanks even if there is no text
on the right side of the rectangle."
295
  (interactive "*r\nP")
296
  (apply-on-rectangle 'open-rectangle-line start end fill)
297
  (goto-char start))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
298

299 300 301 302 303 304 305 306 307 308 309 310 311
(defun open-rectangle-line (startcol endcol fill)
  (let (spaces)
    (when (= (move-to-column-force startcol (or fill 'coerce)) startcol)
      (unless (and (not fill)
		   (= (point) (point-at-eol)))
	(indent-to endcol)))
    ))

(defun delete-whitespace-rectangle-line (startcol endcol fill)
  (when (= (move-to-column-force startcol (or fill 'coerce)) startcol)
    (unless (= (point) (point-at-eol))
      (delete-region (point) (progn (skip-syntax-forward " ") (point))))
    ))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
312

313
;;;###autoload (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name
314
;;;###autoload
315
(defun delete-whitespace-rectangle (start end &optional fill)
316 317 318
  "Delete all whitespace following a specified column in each line.
The left edge of the rectangle specifies the position in each line
at which whitespace deletion should begin.  On each line in the
319
rectangle, all continuous whitespace starting at that column is deleted.
320

321
When called from a program the rectangle's corners are START and END.
322
With a prefix (or a FILL) argument, also fill too short lines."
323
  (interactive "*r\nP")
324 325 326
  (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill))

;; not used any more --dv
327 328 329
;; string-rectangle uses this variable to pass the string
;; to string-rectangle-line.
(defvar string-rectangle-string)
330

331
;;;###autoload
332
(defun string-rectangle (start end string)
333 334 335 336 337 338
  "Insert STRING on each line of the region-rectangle, shifting text right.

When called from a program the rectangle's corners are START and END.
The left edge of the rectangle specifies the column for insertion.
This command does not delete or overwrite any existing text."
  (interactive "*r\nsString rectangle: ")
339 340 341 342 343
  (apply-on-rectangle 'string-rectangle-line start end string))

(defun string-rectangle-line (startcol endcol string)
  (move-to-column-force startcol)
  (insert string))
344

Jim Blandy's avatar
Jim Blandy committed
345
;;;###autoload
346
(defun clear-rectangle (start end &optional fill)
347 348
  "Blank out the region-rectangle.
The text previously in the region is overwritten with blanks.
349

350
When called from a program the rectangle's corners are START and END.
351 352
With a prefix (or a FILL) argument, also fill with blanks the parts of the
rectangle which were empty."
353
  (interactive "*r\nP")
354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
  (apply-on-rectangle 'clear-rectangle-line start end fill))

(defun clear-rectangle-line (startcol endcol fill)
  (let ((pt (point-at-eol))
	spaces)
    (when (= (move-to-column-force startcol (or fill 'coerce)) startcol)
      (if (and (not fill)
	       (<= (save-excursion (goto-char pt) (current-column)) endcol))
	  (delete-region (point) pt)
	;; else
	(setq pt (point))
	(move-to-column-force endcol)
	(setq spaces (- (point) pt))
	(delete-region pt (point))
	(indent-to (+ (current-column) spaces))))
    ))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
370

371
(provide 'rect)
Eric S. Raymond's avatar
Eric S. Raymond committed
372 373

;;; rect.el ends here