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

3
;; Copyright (C) 1985, 1999, 2000, 2001, 2002, 2003, 2004
4
;;   2005, 2006 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
      (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines))))
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
    ))

;; ### 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
165 166 167 168 169 170
    (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)
171 172
			   (substring line (+ (length line)
					      (- (point) end)))))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
173 174 175 176
    (if (or (> begextra 0) (> endextra 0))
	(setq line (concat (spaces-string begextra)
			   line
			   (spaces-string endextra))))
177
    (setcdr lines (cons line (cdr lines)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
178 179 180 181

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

182
;; this one is untouched --dv
Joseph Arceneaux's avatar
Joseph Arceneaux committed
183
(defun spaces-string (n)
184
  "Returns a string with N spaces."
Joseph Arceneaux's avatar
Joseph Arceneaux committed
185
  (if (<= n 8) (aref spaces-strings n)
186
    (make-string n ? )))
187

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

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

206
When called from a program the rectangle's corners are START and END.
207 208 209 210 211
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
212

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

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

Jim Blandy's avatar
Jim Blandy committed
224
;;;###autoload
225
(defun kill-rectangle (start end &optional fill)
226 227 228 229
  "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.
230 231

With a prefix (or a FILL) argument, also fill lines where nothing has to be
232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
deleted.

If the buffer is read-only, Emacs will beep and refrain from deleting
the rectangle, but put it in the kill ring anyway.  This means that
you can use this command to copy text from a read-only buffer.
\(If the variable `kill-read-only-ok' is non-nil, then this won't
even beep.)"
  (interactive "r\nP")
  (condition-case nil
      (setq killed-rectangle (delete-extract-rectangle start end fill))
    ((buffer-read-only text-read-only)
     (setq killed-rectangle (extract-rectangle start end))
     (if kill-read-only-ok
	 (progn (message "Read only text copied to kill ring") nil)
       (barf-if-buffer-read-only)
       (signal 'text-read-only (list (current-buffer)))))))
248 249

;; this one is untouched --dv
Jim Blandy's avatar
Jim Blandy committed
250
;;;###autoload
Joseph Arceneaux's avatar
Joseph Arceneaux committed
251 252
(defun yank-rectangle ()
  "Yank the last killed rectangle with upper left corner at point."
253
  (interactive "*")
Joseph Arceneaux's avatar
Joseph Arceneaux committed
254 255
  (insert-rectangle killed-rectangle))

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

Jim Blandy's avatar
Jim Blandy committed
279
;;;###autoload
280
(defun open-rectangle (start end &optional fill)
281 282 283 284
  "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.
285

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

293
(defun open-rectangle-line (startcol endcol fill)
294
  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
295 296 297
    (unless (and (not fill)
		 (= (point) (point-at-eol)))
      (indent-to endcol))))
298 299

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

304 305 306
;;;###autoload
(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name

307
;;;###autoload
308
(defun delete-whitespace-rectangle (start end &optional fill)
309 310 311
  "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
312
rectangle, all continuous whitespace starting at that column is deleted.
313

314
When called from a program the rectangle's corners are START and END.
315
With a prefix (or a FILL) argument, also fill too short lines."
316
  (interactive "*r\nP")
317 318 319
  (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill))

;; not used any more --dv
320 321 322
;; string-rectangle uses this variable to pass the string
;; to string-rectangle-line.
(defvar string-rectangle-string)
323
(defvar string-rectangle-history nil)
324
(defun string-rectangle-line (startcol endcol string delete)
325
  (move-to-column startcol t)
326 327
  (if delete
      (delete-rectangle-line startcol endcol nil))
328
  (insert string))
329

330
;;;###autoload
331 332 333 334 335
(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."
336 337 338 339 340
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
341
	   (read-string (format "String rectangle (default %s): "
342 343 344
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
345
  (apply-on-rectangle 'string-rectangle-line start end string t))
346

347
;;;###autoload
348 349 350 351 352 353 354 355 356
(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."
357 358 359 360 361
  (interactive
   (progn (barf-if-buffer-read-only)
	  (list
	   (region-beginning)
	   (region-end)
362
	   (read-string (format "String insert rectangle (default %s): "
363 364 365
				(or (car string-rectangle-history) ""))
			nil 'string-rectangle-history
			(car string-rectangle-history)))))
366 367
  (apply-on-rectangle 'string-rectangle-line start end string nil))

Jim Blandy's avatar
Jim Blandy committed
368
;;;###autoload
369
(defun clear-rectangle (start end &optional fill)
370 371
  "Blank out the region-rectangle.
The text previously in the region is overwritten with blanks.
372

373
When called from a program the rectangle's corners are START and END.
374 375
With a prefix (or a FILL) argument, also fill with blanks the parts of the
rectangle which were empty."
376
  (interactive "*r\nP")
377 378 379
  (apply-on-rectangle 'clear-rectangle-line start end fill))

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

392
(provide 'rect)
Eric S. Raymond's avatar
Eric S. Raymond committed
393

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