Return to rect.el CVS log

Up to [Apple XNU] / GNUtools / emacs / lisp

Annotation of GNUtools/emacs/lisp/rect.el, revision 1.1

1.1     ! root        1: ;; Rectangle functions for GNU Emacs.
        !             2: ;; Copyright (C) 1985 Free Software Foundation, Inc.
        !             3: 
        !             4: ;; This file is part of GNU Emacs.
        !             5: 
        !             6: ;; GNU Emacs is free software; you can redistribute it and/or modify
        !             7: ;; it under the terms of the GNU General Public License as published by
        !             8: ;; the Free Software Foundation; either version 1, or (at your option)
        !             9: ;; any later version.
        !            10: 
        !            11: ;; GNU Emacs is distributed in the hope that it will be useful,
        !            12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
        !            13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
        !            14: ;; GNU General Public License for more details.
        !            15: 
        !            16: ;; You should have received a copy of the GNU General Public License
        !            17: ;; along with GNU Emacs; see the file COPYING.  If not, write to
        !            18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
        !            19: 
        !            20: 
        !            21: (defun operate-on-rectangle (function start end coerce-tabs)
        !            22:   "Call FUNCTION for each line of rectangle with corners at START, END.
        !            23: If COERCE-TABS is non-nil, convert multi-column characters
        !            24: that span the starting or ending columns on any line
        !            25: to multiple spaces before calling FUNCTION.
        !            26: FUNCTION is called with three arguments:
        !            27:  position of start of segment of this line within the rectangle,
        !            28:  number of columns that belong to rectangle but are before that position,
        !            29:  number of columns that belong to rectangle but are after point.
        !            30: Point is at the end of the segment of this line within the rectangle."
        !            31:   (let (startcol startlinepos endcol endlinepos)
        !            32:     (save-excursion
        !            33:      (goto-char start)
        !            34:      (setq startcol (current-column))
        !            35:      (beginning-of-line)
        !            36:      (setq startlinepos (point)))
        !            37:     (save-excursion
        !            38:      (goto-char end)
        !            39:      (setq endcol (current-column))
        !            40:      (forward-line 1)
        !            41:      (setq endlinepos (point-marker)))
        !            42:     (if (< endcol startcol)
        !            43:        (let ((tem startcol))
        !            44:          (setq startcol endcol endcol tem)))
        !            45:     (if (/= endcol startcol)
        !            46:        (save-excursion
        !            47:         (goto-char startlinepos)
        !            48:         (while (< (point) endlinepos)
        !            49:           (let (startpos begextra endextra)
        !            50:             (move-to-column startcol)
        !            51:             (and coerce-tabs
        !            52:                  (> (current-column) startcol)
        !            53:                  (rectangle-coerce-tab startcol))
        !            54:             (setq begextra (- (current-column) startcol))
        !            55:             (setq startpos (point))
        !            56:             (move-to-column endcol)
        !            57:             (if (> (current-column) endcol)
        !            58:                 (if coerce-tabs
        !            59:                     (rectangle-coerce-tab endcol)
        !            60:                   (forward-char -1)))
        !            61:             (setq endextra (- endcol (current-column)))
        !            62:             (if (< begextra 0)
        !            63:                 (setq endextra (+ endextra begextra)
        !            64:                       begextra 0))
        !            65:             (funcall function startpos begextra endextra))
        !            66:           (forward-line 1))))
        !            67:     (- endcol startcol)))
        !            68: 
        !            69: (defun delete-rectangle-line (startdelpos ignore ignore)
        !            70:   (delete-region startdelpos (point)))
        !            71: 
        !            72: (defun delete-extract-rectangle-line (startdelpos begextra endextra)
        !            73:   (save-excursion
        !            74:    (extract-rectangle-line startdelpos begextra endextra))
        !            75:   (delete-region startdelpos (point)))
        !            76: 
        !            77: (defun extract-rectangle-line (startdelpos begextra endextra)
        !            78:   (let ((line (buffer-substring startdelpos (point)))
        !            79:        (end (point)))
        !            80:     (goto-char startdelpos)
        !            81:     (while (search-forward "\t" end t)
        !            82:       (let ((width (- (current-column)
        !            83:                      (save-excursion (forward-char -1)
        !            84:                                      (current-column)))))
        !            85:        (setq line (concat (substring line 0 (- (point) end 1))
        !            86:                           (spaces-string width)
        !            87:                           (substring line (+ (length line) (- (point) end)))))))
        !            88:     (if (or (> begextra 0) (> endextra 0))
        !            89:        (setq line (concat (spaces-string begextra)
        !            90:                           line
        !            91:                           (spaces-string endextra))))
        !            92:     (setq lines (cons line lines))))
        !            93: 
        !            94: (defconst spaces-strings
        !            95:   '["" " " "  " "   " "    " "     " "      " "       " "        "])
        !            96: 
        !            97: (defun spaces-string (n)
        !            98:   (if (<= n 8) (aref spaces-strings n)
        !            99:     (let ((val ""))
        !           100:       (while (> n 8)
        !           101:        (setq val (concat "        " val)
        !           102:              n (- n 8)))
        !           103:       (concat val (aref spaces-strings n)))))
        !           104:     
        !           105: (defun delete-rectangle (start end)
        !           106:   "Delete (don't save) text in rectangle with point and mark as corners.
        !           107: The same range of columns is deleted in each line
        !           108: starting with the line where the region begins
        !           109: and ending with the line where the region ends."
        !           110:   (interactive "r")
        !           111:   (operate-on-rectangle 'delete-rectangle-line start end t))
        !           112: 
        !           113: (defun delete-extract-rectangle (start end)
        !           114:   "Return and delete contents of rectangle with corners at START and END.
        !           115: Value is list of strings, one for each line of the rectangle."
        !           116:   (let (lines)
        !           117:     (operate-on-rectangle 'delete-extract-rectangle-line
        !           118:                          start end t)
        !           119:     (nreverse lines)))
        !           120: 
        !           121: (defun extract-rectangle (start end)
        !           122:   "Return contents of rectangle with corners at START and END.
        !           123: Value is list of strings, one for each line of the rectangle."
        !           124:   (let (lines)
        !           125:     (operate-on-rectangle 'extract-rectangle-line start end nil)
        !           126:     (nreverse lines)))
        !           127: 
        !           128: (defvar killed-rectangle nil
        !           129:   "Rectangle for yank-rectangle to insert.")
        !           130: 
        !           131: (defun kill-rectangle (start end)
        !           132:   "Delete rectangle with corners at point and mark; save as last killed one.
        !           133: Calling from program, supply two args START and END, buffer positions.
        !           134: But in programs you might prefer to use delete-extract-rectangle."
        !           135:   (interactive "r")
        !           136:   (setq killed-rectangle (delete-extract-rectangle start end)))
        !           137: 
        !           138: (defun yank-rectangle ()
        !           139:   "Yank the last killed rectangle with upper left corner at point."
        !           140:   (interactive)
        !           141:   (insert-rectangle killed-rectangle))
        !           142: 
        !           143: (defun insert-rectangle (rectangle)
        !           144:   "Insert text of RECTANGLE with upper left corner at point.
        !           145: RECTANGLE's first line is inserted at point,
        !           146: its second line is inserted at a point vertically under point, etc.
        !           147: RECTANGLE should be a list of strings."
        !           148:   (let ((lines rectangle)
        !           149:        (insertcolumn (current-column))
        !           150:        (first t))
        !           151:     (while lines
        !           152:       (or first
        !           153:          (progn
        !           154:           (forward-line 1)
        !           155:           (or (bolp) (insert ?\n))
        !           156:           (move-to-column insertcolumn)
        !           157:           (if (> (current-column) insertcolumn)
        !           158:               (rectangle-coerce-tab insertcolumn))
        !           159:           (if (< (current-column) insertcolumn)
        !           160:               (indent-to insertcolumn))))
        !           161:       (setq first nil)
        !           162:       (insert (car lines))
        !           163:       (setq lines (cdr lines)))))
        !           164: 
        !           165: (defun open-rectangle (start end)
        !           166:   "Blank out rectangle with corners at point and mark, shifting text right.
        !           167: The text previously in the region is not overwritten by the blanks,
        !           168: but insted winds up to the right of the rectangle."
        !           169:   (interactive "r")
        !           170:   (operate-on-rectangle 'open-rectangle-line start end nil))
        !           171: 
        !           172: (defun open-rectangle-line (startpos begextra endextra)
        !           173:   (let ((column (+ (current-column) begextra endextra)))
        !           174:     (goto-char startpos)
        !           175:     (let ((ocol (current-column)))
        !           176:       (skip-chars-forward " \t")
        !           177:       (setq column (+ column (- (current-column) ocol))))
        !           178:     (delete-region (point)
        !           179:                    (progn (skip-chars-backward " \t")
        !           180:                          (point)))
        !           181:     (indent-to column)))
        !           182: 
        !           183: (defun clear-rectangle (start end &optional preserve-position)
        !           184:   "Blank out rectangle with corners at point and mark.
        !           185: The text previously in the region is overwritten by the blanks."
        !           186:   (interactive "r")
        !           187:   (operate-on-rectangle 'clear-rectangle-line start end t))
        !           188: 
        !           189: (defun clear-rectangle-line (startpos begextra endextra)
        !           190:   (skip-chars-forward " \t")
        !           191:   (let ((column (+ (current-column) endextra)))
        !           192:     (delete-region (point)
        !           193:                    (progn (goto-char startpos)
        !           194:                          (or preserve-position
        !           195:                              (skip-chars-backward " \t"))
        !           196:                          (point)))
        !           197:     (indent-to column)))
        !           198: 
        !           199: (defun rectangle-coerce-tab (column)
        !           200:   (let ((aftercol (current-column))
        !           201:        (indent-tabs-mode nil))
        !           202:     (delete-char -1)
        !           203:     (indent-to aftercol)
        !           204:     (backward-char (- aftercol column))))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.