diff options
author | Joseph Arceneaux <jla@gnu.org> | 1989-10-31 16:00:07 +0000 |
---|---|---|
committer | Joseph Arceneaux <jla@gnu.org> | 1989-10-31 16:00:07 +0000 |
commit | d32fc917b72eb88a71da76de738b6c91f94a702e (patch) | |
tree | e3d3283293e51fdd6b426e4221a9b6aade6b2f0e /lisp/rect.el | |
parent | ac1c6ea2915c86f32904c13ad6be2db16487003e (diff) | |
download | emacs-d32fc917b72eb88a71da76de738b6c91f94a702e.tar.gz |
Initial revision
Diffstat (limited to 'lisp/rect.el')
-rw-r--r-- | lisp/rect.el | 205 |
1 files changed, 205 insertions, 0 deletions
diff --git a/lisp/rect.el b/lisp/rect.el new file mode 100644 index 00000000000..3dd06f1be0e --- /dev/null +++ b/lisp/rect.el @@ -0,0 +1,205 @@ +;; Rectangle functions for GNU Emacs. +;; Copyright (C) 1985 Free Software Foundation, Inc. + +;; 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 +;; the Free Software Foundation; either version 1, or (at your option) +;; 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 +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(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) + (let ((tem startcol)) + (setq startcol endcol endcol tem))) + (if (/= endcol startcol) + (save-excursion + (goto-char startlinepos) + (while (< (point) endlinepos) + (let (startpos begextra endextra) + (move-to-column startcol) + (and coerce-tabs + (> (current-column) startcol) + (rectangle-coerce-tab startcol)) + (setq begextra (- (current-column) startcol)) + (setq startpos (point)) + (move-to-column endcol) + (if (> (current-column) endcol) + (if coerce-tabs + (rectangle-coerce-tab endcol) + (forward-char -1))) + (setq endextra (- endcol (current-column))) + (if (< begextra 0) + (setq endextra (+ endextra begextra) + begextra 0)) + (funcall function startpos begextra endextra)) + (forward-line 1)))) + (- endcol startcol))) + +(defun delete-rectangle-line (startdelpos ignore ignore) + (delete-region startdelpos (point))) + +(defun delete-extract-rectangle-line (startdelpos begextra endextra) + (save-excursion + (extract-rectangle-line startdelpos begextra endextra)) + (delete-region startdelpos (point))) + +(defun extract-rectangle-line (startdelpos begextra endextra) + (let ((line (buffer-substring startdelpos (point))) + (end (point))) + (goto-char startdelpos) + (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) + (substring line (+ (length line) (- (point) end))))))) + (if (or (> begextra 0) (> endextra 0)) + (setq line (concat (spaces-string begextra) + line + (spaces-string endextra)))) + (setq lines (cons line lines)))) + +(defconst spaces-strings + '["" " " " " " " " " " " " " " " " "]) + +(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))))) + +(defun delete-rectangle (start end) + "Delete (don't save) text in rectangle with point and mark as corners. +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." + (interactive "r") + (operate-on-rectangle 'delete-rectangle-line start end t)) + +(defun delete-extract-rectangle (start end) + "Delete contents of rectangle and return it as a list of strings. +Arguments START and END are the corners of the rectangle. +The value is list of strings, one for each line of the rectangle." + (let (lines) + (operate-on-rectangle 'delete-extract-rectangle-line + start end t) + (nreverse lines))) + +(defun extract-rectangle (start end) + "Return contents of rectangle with corners at START and END. +Value is list of strings, one for each line of the rectangle." + (let (lines) + (operate-on-rectangle 'extract-rectangle-line start end nil) + (nreverse lines))) + +(defvar killed-rectangle nil + "Rectangle for yank-rectangle to insert.") + +(defun kill-rectangle (start end) + "Delete rectangle with corners at point and mark; save as last killed one. +Calling from program, supply two args START and END, buffer positions. +But in programs you might prefer to use delete-extract-rectangle." + (interactive "r") + (setq killed-rectangle (delete-extract-rectangle start end))) + +(defun yank-rectangle () + "Yank the last killed rectangle with upper left corner at point." + (interactive) + (insert-rectangle killed-rectangle)) + +(defun insert-rectangle (rectangle) + "Insert text of RECTANGLE with upper left corner at point. +RECTANGLE's first line is inserted at point, +its second line is inserted at a point vertically under point, etc. +RECTANGLE should be a list of strings." + (let ((lines rectangle) + (insertcolumn (current-column)) + (first t)) + (while lines + (or first + (progn + (forward-line 1) + (or (bolp) (insert ?\n)) + (move-to-column insertcolumn) + (if (> (current-column) insertcolumn) + (rectangle-coerce-tab insertcolumn)) + (if (< (current-column) insertcolumn) + (indent-to insertcolumn)))) + (setq first nil) + (insert (car lines)) + (setq lines (cdr lines))))) + +(defun open-rectangle (start end) + "Blank out rectangle with corners at point and mark, shifting text right. +The text previously in the region is not overwritten by the blanks, +but insted winds up to the right of the rectangle." + (interactive "r") + (operate-on-rectangle 'open-rectangle-line start end nil)) + +(defun open-rectangle-line (startpos begextra endextra) + (let ((column (+ (current-column) begextra endextra))) + (goto-char startpos) + (let ((ocol (current-column))) + (skip-chars-forward " \t") + (setq column (+ column (- (current-column) ocol)))) + (delete-region (point) + (progn (skip-chars-backward " \t") + (point))) + (indent-to column))) + +(defun clear-rectangle (start end) + "Blank out rectangle with corners at point and mark. +The text previously in the region is overwritten by the blanks. +When called from a program, requires two args which specify the corners." + (interactive "r") + (operate-on-rectangle 'clear-rectangle-line start end t)) + +(defun clear-rectangle-line (startpos begextra endextra) + (skip-chars-forward " \t") + (let ((column (+ (current-column) endextra))) + (delete-region (point) + (progn (goto-char startpos) + (skip-chars-backward " \t") + (point))) + (indent-to column))) + +(defun rectangle-coerce-tab (column) + (let ((aftercol (current-column)) + (indent-tabs-mode nil)) + (delete-char -1) + (indent-to aftercol) + (backward-char (- aftercol column)))) |