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

3 4
;; Copyright (C) 1985, 1999, 2000, 2001, 2002, 2003, 2004
;;   2005 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
5

6
;; Maintainer: Didier Verna <didier@xemacs.org>
Eric S. Raymond's avatar
Eric S. Raymond committed
7
;; Keywords: internal
Eric S. Raymond's avatar
Eric S. Raymond committed
8

Joseph Arceneaux's avatar
Joseph Arceneaux committed
9 10 11 12
;; 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
13
;; the Free Software Foundation; either version 2, or (at your option)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
14 15 16 17 18 19 20 21
;; 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
22
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
23 24
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
25

26 27
;;; Commentary:

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

31
;; ### NOTE: this file has been almost completely rewritten by Didier Verna
32
;; <didier@xemacs.org> in July 1999. The purpose of this rewrite is to be less
33 34 35 36
;; 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
37
;;; Code:
Joseph Arceneaux's avatar
Joseph Arceneaux committed
38

39
;;;###autoload
40
(defun move-to-column-force (column &optional flag)
41
  "If COLUMN is within a multi-column character, replace it by spaces and tab.
42 43
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."
44
  (move-to-column column (or flag t)))
45 46

;;;###autoload
47
(make-obsolete 'move-to-column-force 'move-to-column "21.2")
48

49
;; not used any more --dv
50 51 52 53
;; extract-rectangle-line stores lines into this list
;; to accumulate them for extract-rectangle and delete-extract-rectangle.
(defvar operate-on-rectangle-lines)

54
;; ### NOTE: this function is untouched, but not used anymore apart from
55
;; `delete-whitespace-rectangle'. `apply-on-rectangle' is used instead. --dv
Joseph Arceneaux's avatar
Joseph Arceneaux committed
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
(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)
78
	(setq startcol (prog1 endcol (setq endcol startcol))))
79 80 81 82
    (save-excursion
     (goto-char startlinepos)
     (while (< (point) endlinepos)
       (let (startpos begextra endextra)
83
	 (if coerce-tabs
84
	     (move-to-column startcol t)
85
	   (move-to-column startcol))
86 87
	 (setq begextra (- (current-column) startcol))
	 (setq startpos (point))
88
	 (if coerce-tabs
89
	     (move-to-column endcol t)
90
	   (move-to-column endcol))
91 92 93 94
	 ;; If we overshot, move back one character
	 ;; so that endextra will be positive.
	 (if (and (not coerce-tabs) (> (current-column) endcol))
	     (backward-char 1))
95 96 97 98 99 100
	 (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
101 102
    (- endcol startcol)))

103 104 105 106
;; 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
107
rectangle, plus ARGS extra arguments.  Point is at the beginning of line when
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130
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)
131
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
132 133 134
    (delete-region (point)
		   (progn (move-to-column endcol 'coerce)
			  (point)))))
135 136 137

(defun delete-extract-rectangle-line (startcol endcol lines fill)
  (let ((pt (point-at-eol)))
138
    (if (< (move-to-column startcol (if fill t 'coerce)) startcol)
139 140 141 142
	(setcdr lines (cons (spaces-string (- endcol startcol))
			    (cdr lines)))
      ;; else
      (setq pt (point))
143
      (move-to-column endcol t)
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
      (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
166 167 168 169 170 171
    (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)
172 173
			   (substring line (+ (length line)
					      (- (point) end)))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
174 175 176 177
    (if (or (> begextra 0) (> endextra 0))
	(setq line (concat (spaces-string begextra)
			   line
			   (spaces-string endextra))))
178
    (setcdr lines (cons line (cdr lines)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
179 180 181 182

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

183
;; this one is untouched --dv
Joseph Arceneaux's avatar
Joseph Arceneaux committed
184 185 186 187 188 189 190
(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)))))
191

Jim Blandy's avatar
Jim Blandy committed
192
;;;###autoload
193
(defun delete-rectangle (start end &optional fill)
194 195 196 197 198 199 200 201 202
  "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")
203
  (apply-on-rectangle 'delete-rectangle-line start end fill))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
204

Jim Blandy's avatar
Jim Blandy committed
205
;;;###autoload
206
(defun delete-extract-rectangle (start end &optional fill)
207
  "Delete the contents of the rectangle with corners at START and END.
208
Return it as a list of strings, one for each line of the rectangle.
209

210
When called from a program the rectangle's corners are START and END.
211 212 213 214 215
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
216

Jim Blandy's avatar
Jim Blandy committed
217
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
218
(defun extract-rectangle (start end)
219 220
  "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."
221 222 223
  (let ((lines (list nil)))
    (apply-on-rectangle 'extract-rectangle-line start end lines)
    (nreverse (cdr lines))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
224 225

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

Jim Blandy's avatar
Jim Blandy committed
228
;;;###autoload
229
(defun kill-rectangle (start end &optional fill)
230 231 232 233
  "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.
234 235 236

With a prefix (or a FILL) argument, also fill lines where nothing has to be
deleted."
237
  (interactive "*r\nP")
238 239 240 241 242 243
  (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
244
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
245 246
(defun yank-rectangle ()
  "Yank the last killed rectangle with upper left corner at point."
247
  (interactive "*")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
248 249
  (insert-rectangle killed-rectangle))

250
;; this one is untoutched --dv
Jim Blandy's avatar
Jim Blandy committed
251
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
252 253
(defun insert-rectangle (rectangle)
  "Insert text of RECTANGLE with upper left corner at point.
254 255
RECTANGLE's first line is inserted at point, its second
line is inserted at a point vertically under point, etc.
256 257 258
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
259 260 261
  (let ((lines rectangle)
	(insertcolumn (current-column))
	(first t))
262
    (push-mark)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
263 264 265 266 267
    (while lines
      (or first
	  (progn
	   (forward-line 1)
	   (or (bolp) (insert ?\n))
268
	   (move-to-column insertcolumn t)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
269
      (setq first nil)
270
      (insert-for-yank (car lines))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
271 272
      (setq lines (cdr lines)))))

Jim Blandy's avatar
Jim Blandy committed
273
;;;###autoload
274
(defun open-rectangle (start end &optional fill)
275 276 277 278
  "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.
279

280
When called from a program the rectangle's corners are START and END.
281 282
With a prefix (or a FILL) argument, fill with blanks even if there is no text
on the right side of the rectangle."
283
  (interactive "*r\nP")
284
  (apply-on-rectangle 'open-rectangle-line start end fill)
285
  (goto-char start))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
286

287
(defun open-rectangle-line (startcol endcol fill)
288
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
289 290 291
    (unless (and (not fill)
		 (= (point) (point-at-eol)))
      (indent-to endcol))))
292 293

(defun delete-whitespace-rectangle-line (startcol endcol fill)
294
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
295
    (unless (= (point) (point-at-eol))
296
      (delete-region (point) (progn (skip-syntax-forward " ") (point))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
297

298 299 300
;;;###autoload
(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name

301
;;;###autoload
302
(defun delete-whitespace-rectangle (start end &optional fill)
303 304 305
  "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
306
rectangle, all continuous whitespace starting at that column is deleted.
307

308
When called from a program the rectangle's corners are START and END.
309
With a prefix (or a FILL) argument, also fill too short lines."
310
  (interactive "*r\nP")
311 312 313
  (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill))

;; not used any more --dv
314 315 316
;; string-rectangle uses this variable to pass the string
;; to string-rectangle-line.
(defvar string-rectangle-string)
317
(defvar string-rectangle-history nil)
318
(defun string-rectangle-line (startcol endcol string delete)
319
  (move-to-column startcol t)
320 321
  (if delete
      (delete-rectangle-line startcol endcol nil))
322
  (insert string))
323

324
;;;###autoload
325 326 327 328 329
(defun string-rectangle (start end string)
  "Replace rectangle contents with STRING on each line.
The length of STRING need not be the same as the rectangle width.

Called from a program, takes three args; START, END and STRING."
330 331 332 333 334 335 336 337 338
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
	   (read-string (format "String rectangle (default `%s'): "
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
339
  (apply-on-rectangle 'string-rectangle-line start end string t))
340

341
;;;###autoload
342 343 344 345 346 347 348 349 350
(defalias 'replace-rectangle 'string-rectangle)

;;;###autoload
(defun string-insert-rectangle (start end string)
  "Insert STRING on each line of 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."
351 352 353 354 355 356 357 358 359
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
	   (read-string (format "String insert rectangle (default `%s'): "
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
360 361
  (apply-on-rectangle 'string-rectangle-line start end string nil))

Jim Blandy's avatar
Jim Blandy committed
362
;;;###autoload
363
(defun clear-rectangle (start end &optional fill)
364 365
  "Blank out the region-rectangle.
The text previously in the region is overwritten with blanks.
366

367
When called from a program the rectangle's corners are START and END.
368 369
With a prefix (or a FILL) argument, also fill with blanks the parts of the
rectangle which were empty."
370
  (interactive "*r\nP")
371 372 373
  (apply-on-rectangle 'clear-rectangle-line start end fill))

(defun clear-rectangle-line (startcol endcol fill)
374
  (let ((pt (point-at-eol)))
375
    (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
376 377 378 379 380
      (if (and (not fill)
	       (<= (save-excursion (goto-char pt) (current-column)) endcol))
	  (delete-region (point) pt)
	;; else
	(setq pt (point))
381
	(move-to-column endcol t)
382
	(setq endcol (current-column))
383
	(delete-region pt (point))
384
	(indent-to endcol)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
385

386
(provide 'rect)
Eric S. Raymond's avatar
Eric S. Raymond committed
387

Miles Bader's avatar
Miles Bader committed
388
;;; arch-tag: 178847b3-1f50-4b03-83de-a6e911cc1d16
Eric S. Raymond's avatar
Eric S. Raymond committed
389
;;; rect.el ends here