1;;; rect.el --- rectangle functions for GNU Emacs 2 3;; Copyright (C) 1985, 1999, 2000, 2001, 2002, 2003, 2004 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Maintainer: Didier Verna <didier@xemacs.org> 7;; Keywords: internal 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; This package provides the operations on rectangles that are documented 29;; in the Emacs manual. 30 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;; intrusive and fill lines with whitespaces only when needed. A few functions 34;; are untouched though, as noted above their definition. 35 36 37;;; Code: 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. 42As for `move-to-column', passing anything but nil or t in FLAG will move to 43the 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;; extract-rectangle-line stores lines into this list 51;; to accumulate them for extract-rectangle and delete-extract-rectangle. 52(defvar operate-on-rectangle-lines) 53 54;; ### NOTE: this function is untouched, but not used anymore apart from 55;; `delete-whitespace-rectangle'. `apply-on-rectangle' is used instead. --dv 56(defun operate-on-rectangle (function start end coerce-tabs) 57 "Call FUNCTION for each line of rectangle with corners at START, END. 58If COERCE-TABS is non-nil, convert multi-column characters 59that span the starting or ending columns on any line 60to multiple spaces before calling FUNCTION. 61FUNCTION is called with three arguments: 62 position of start of segment of this line within the rectangle, 63 number of columns that belong to rectangle but are before that position, 64 number of columns that belong to rectangle but are after point. 65Point is at the end of the segment of this line within the rectangle." 66 (let (startcol startlinepos endcol endlinepos) 67 (save-excursion 68 (goto-char start) 69 (setq startcol (current-column)) 70 (beginning-of-line) 71 (setq startlinepos (point))) 72 (save-excursion 73 (goto-char end) 74 (setq endcol (current-column)) 75 (forward-line 1) 76 (setq endlinepos (point-marker))) 77 (if (< endcol startcol) 78 (setq startcol (prog1 endcol (setq endcol startcol)))) 79 (save-excursion 80 (goto-char startlinepos) 81 (while (< (point) endlinepos) 82 (let (startpos begextra endextra) 83 (if coerce-tabs 84 (move-to-column startcol t) 85 (move-to-column startcol)) 86 (setq begextra (- (current-column) startcol)) 87 (setq startpos (point)) 88 (if coerce-tabs 89 (move-to-column endcol t) 90 (move-to-column endcol)) 91 ;; If we overshot, move back one character 92 ;; so that endextra will be positive. 93 (if (and (not coerce-tabs) (> (current-column) endcol)) 94 (backward-char 1)) 95 (setq endextra (- endcol (current-column))) 96 (if (< begextra 0) 97 (setq endextra (+ endextra begextra) 98 begextra 0)) 99 (funcall function startpos begextra endextra)) 100 (forward-line 1))) 101 (- endcol startcol))) 102 103;; The replacement for `operate-on-rectangle' -- dv 104(defun apply-on-rectangle (function start end &rest args) 105 "Call FUNCTION for each line of rectangle with corners at START, END. 106FUNCTION is called with two arguments: the start and end columns of the 107rectangle, plus ARGS extra arguments. Point is at the beginning of line when 108the function is called." 109 (let (startcol startpt endcol endpt) 110 (save-excursion 111 (goto-char start) 112 (setq startcol (current-column)) 113 (beginning-of-line) 114 (setq startpt (point)) 115 (goto-char end) 116 (setq endcol (current-column)) 117 (forward-line 1) 118 (setq endpt (point-marker)) 119 ;; ensure the start column is the left one. 120 (if (< endcol startcol) 121 (let ((col startcol)) 122 (setq startcol endcol endcol col))) 123 ;; start looping over lines 124 (goto-char startpt) 125 (while (< (point) endpt) 126 (apply function startcol endcol args) 127 (forward-line 1))) 128 )) 129 130(defun delete-rectangle-line (startcol endcol fill) 131 (when (= (move-to-column startcol (if fill t 'coerce)) startcol) 132 (delete-region (point) 133 (progn (move-to-column endcol 'coerce) 134 (point))))) 135 136(defun delete-extract-rectangle-line (startcol endcol lines fill) 137 (let ((pt (point-at-eol))) 138 (if (< (move-to-column startcol (if fill t 'coerce)) startcol) 139 (setcdr lines (cons (spaces-string (- endcol startcol)) 140 (cdr lines))) 141 ;; else 142 (setq pt (point)) 143 (move-to-column endcol t) 144 (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines)))) 145 )) 146 147;; ### NOTE: this is actually the only function that needs to do complicated 148;; stuff like what's happening in `operate-on-rectangle', because the buffer 149;; might be read-only. --dv 150(defun extract-rectangle-line (startcol endcol lines) 151 (let (start end begextra endextra line) 152 (move-to-column startcol) 153 (setq start (point) 154 begextra (- (current-column) startcol)) 155 (move-to-column endcol) 156 (setq end (point) 157 endextra (- endcol (current-column))) 158 (setq line (buffer-substring start (point))) 159 (if (< begextra 0) 160 (setq endextra (+ endextra begextra) 161 begextra 0)) 162 (if (< endextra 0) 163 (setq endextra 0)) 164 (goto-char start) 165 (while (search-forward "\t" end t) 166 (let ((width (- (current-column) 167 (save-excursion (forward-char -1) 168 (current-column))))) 169 (setq line (concat (substring line 0 (- (point) end 1)) 170 (spaces-string width) 171 (substring line (+ (length line) 172 (- (point) end))))))) 173 (if (or (> begextra 0) (> endextra 0)) 174 (setq line (concat (spaces-string begextra) 175 line 176 (spaces-string endextra)))) 177 (setcdr lines (cons line (cdr lines))))) 178 179(defconst spaces-strings 180 '["" " " " " " " " " " " " " " " " "]) 181 182;; this one is untouched --dv 183(defun spaces-string (n) 184 "Returns a string with N spaces." 185 (if (<= n 8) (aref spaces-strings n) 186 (make-string n ? ))) 187 188;;;###autoload 189(defun delete-rectangle (start end &optional fill) 190 "Delete (don't save) text in the region-rectangle. 191The same range of columns is deleted in each line starting with the 192line where the region begins and ending with the line where the region 193ends. 194 195When called from a program the rectangle's corners are START and END. 196With a prefix (or a FILL) argument, also fill lines where nothing has 197to be deleted." 198 (interactive "*r\nP") 199 (apply-on-rectangle 'delete-rectangle-line start end fill)) 200 201;;;###autoload 202(defun delete-extract-rectangle (start end &optional fill) 203 "Delete the contents of the rectangle with corners at START and END. 204Return it as a list of strings, one for each line of the rectangle. 205 206When called from a program the rectangle's corners are START and END. 207With an optional FILL argument, also fill lines where nothing has to be 208deleted." 209 (let ((lines (list nil))) 210 (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill) 211 (nreverse (cdr lines)))) 212 213;;;###autoload 214(defun extract-rectangle (start end) 215 "Return the contents of the rectangle with corners at START and END. 216Return it as a list of strings, one for each line of the rectangle." 217 (let ((lines (list nil))) 218 (apply-on-rectangle 'extract-rectangle-line start end lines) 219 (nreverse (cdr lines)))) 220 221(defvar killed-rectangle nil 222 "Rectangle for `yank-rectangle' to insert.") 223 224;;;###autoload 225(defun kill-rectangle (start end &optional fill) 226 "Delete the region-rectangle and save it as the last killed one. 227 228When called from a program the rectangle's corners are START and END. 229You might prefer to use `delete-extract-rectangle' from a program. 230 231With a prefix (or a FILL) argument, also fill lines where nothing has to be 232deleted. 233 234If the buffer is read-only, Emacs will beep and refrain from deleting 235the rectangle, but put it in the kill ring anyway. This means that 236you can use this command to copy text from a read-only buffer. 237\(If the variable `kill-read-only-ok' is non-nil, then this won't 238even beep.)" 239 (interactive "r\nP") 240 (condition-case nil 241 (setq killed-rectangle (delete-extract-rectangle start end fill)) 242 ((buffer-read-only text-read-only) 243 (setq killed-rectangle (extract-rectangle start end)) 244 (if kill-read-only-ok 245 (progn (message "Read only text copied to kill ring") nil) 246 (barf-if-buffer-read-only) 247 (signal 'text-read-only (list (current-buffer))))))) 248 249;; this one is untouched --dv 250;;;###autoload 251(defun yank-rectangle () 252 "Yank the last killed rectangle with upper left corner at point." 253 (interactive "*") 254 (insert-rectangle killed-rectangle)) 255 256;; this one is untoutched --dv 257;;;###autoload 258(defun insert-rectangle (rectangle) 259 "Insert text of RECTANGLE with upper left corner at point. 260RECTANGLE's first line is inserted at point, its second 261line is inserted at a point vertically under point, etc. 262RECTANGLE should be a list of strings. 263After this command, the mark is at the upper left corner 264and point is at the lower right corner." 265 (let ((lines rectangle) 266 (insertcolumn (current-column)) 267 (first t)) 268 (push-mark) 269 (while lines 270 (or first 271 (progn 272 (forward-line 1) 273 (or (bolp) (insert ?\n)) 274 (move-to-column insertcolumn t))) 275 (setq first nil) 276 (insert-for-yank (car lines)) 277 (setq lines (cdr lines))))) 278 279;;;###autoload 280(defun open-rectangle (start end &optional fill) 281 "Blank out the region-rectangle, shifting text right. 282 283The text previously in the region is not overwritten by the blanks, 284but instead winds up to the right of the rectangle. 285 286When called from a program the rectangle's corners are START and END. 287With a prefix (or a FILL) argument, fill with blanks even if there is no text 288on the right side of the rectangle." 289 (interactive "*r\nP") 290 (apply-on-rectangle 'open-rectangle-line start end fill) 291 (goto-char start)) 292 293(defun open-rectangle-line (startcol endcol fill) 294 (when (= (move-to-column startcol (if fill t 'coerce)) startcol) 295 (unless (and (not fill) 296 (= (point) (point-at-eol))) 297 (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)))))) 303 304;;;###autoload 305(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name 306 307;;;###autoload 308(defun delete-whitespace-rectangle (start end &optional fill) 309 "Delete all whitespace following a specified column in each line. 310The left edge of the rectangle specifies the position in each line 311at which whitespace deletion should begin. On each line in the 312rectangle, all continuous whitespace starting at that column is deleted. 313 314When called from a program the rectangle's corners are START and END. 315With a prefix (or a FILL) argument, also fill too short lines." 316 (interactive "*r\nP") 317 (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill)) 318 319;; not used any more --dv 320;; string-rectangle uses this variable to pass the string 321;; to string-rectangle-line. 322(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 (if delete 327 (delete-rectangle-line startcol endcol nil)) 328 (insert string)) 329 330;;;###autoload 331(defun string-rectangle (start end string) 332 "Replace rectangle contents with STRING on each line. 333The length of STRING need not be the same as the rectangle width. 334 335Called from a program, takes three args; START, END and STRING." 336 (interactive 337 (progn (barf-if-buffer-read-only) 338 (list 339 (region-beginning) 340 (region-end) 341 (read-string (format "String rectangle (default %s): " 342 (or (car string-rectangle-history) "")) 343 nil 'string-rectangle-history 344 (car string-rectangle-history))))) 345 (apply-on-rectangle 'string-rectangle-line start end string t)) 346 347;;;###autoload 348(defalias 'replace-rectangle 'string-rectangle) 349 350;;;###autoload 351(defun string-insert-rectangle (start end string) 352 "Insert STRING on each line of region-rectangle, shifting text right. 353 354When called from a program, the rectangle's corners are START and END. 355The left edge of the rectangle specifies the column for insertion. 356This command does not delete or overwrite any existing text." 357 (interactive 358 (progn (barf-if-buffer-read-only) 359 (list 360 (region-beginning) 361 (region-end) 362 (read-string (format "String insert rectangle (default %s): " 363 (or (car string-rectangle-history) "")) 364 nil 'string-rectangle-history 365 (car string-rectangle-history))))) 366 (apply-on-rectangle 'string-rectangle-line start end string nil)) 367 368;;;###autoload 369(defun clear-rectangle (start end &optional fill) 370 "Blank out the region-rectangle. 371The text previously in the region is overwritten with blanks. 372 373When called from a program the rectangle's corners are START and END. 374With a prefix (or a FILL) argument, also fill with blanks the parts of the 375rectangle which were empty." 376 (interactive "*r\nP") 377 (apply-on-rectangle 'clear-rectangle-line start end fill)) 378 379(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 (if (and (not fill) 383 (<= (save-excursion (goto-char pt) (current-column)) endcol)) 384 (delete-region (point) pt) 385 ;; else 386 (setq pt (point)) 387 (move-to-column endcol t) 388 (setq endcol (current-column)) 389 (delete-region pt (point)) 390 (indent-to endcol))))) 391 392(provide 'rect) 393 394;;; arch-tag: 178847b3-1f50-4b03-83de-a6e911cc1d16 395;;; rect.el ends here 396