Return to rect.el CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp

Annotation of 43BSD/contrib/emacs/lisp/rect.el, revision 1.1

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