X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/35f901fa576cd5950e0626ac848835c4df612329..c4dd9efc9ed3f7de8f4ee74b6d47f65ad72320cf:/lisp/rect.el diff --git a/lisp/rect.el b/lisp/rect.el index 4d9f034d9b..ec234b6514 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -1,16 +1,17 @@ -;;; rect.el --- rectangle functions for GNU Emacs. +;;; rect.el --- rectangle functions for GNU Emacs -;; Copyright (C) 1985, 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1999-2013 Free Software Foundation, Inc. -;; Maintainer: Didier Verna +;; Maintainer: Didier Verna ;; Keywords: internal +;; Package: emacs ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, 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 @@ -18,48 +19,19 @@ ;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;; This package provides the operations on rectangles that are documented ;; in the Emacs manual. -;; ### NOTE: this file has been almost completely rewritten by Didier Verna -;; in July 1999. The purpose of this rewrite is to be less -;; intrusive and fill lines with whitespaces only when needed. A few functions -;; are untouched though, as noted above their definition. - +;; ### NOTE: this file was almost completely rewritten by Didier Verna +;; in July 1999. ;;; Code: -;;;###autoload -(defun move-to-column-force (column &optional flag) - "Move point to column COLUMN rigidly in the current line. -If COLUMN is within a multi-column character, replace it by -spaces and tab. - -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." - (let ((col (move-to-column column (or flag t)))) - (if (> col column) - (let (pos) - (delete-char -1) - (insert-char ? (- column (current-column))) - (setq pos (point)) - (indent-to col) - (goto-char pos))) - column)) - -;; not used any more --dv -;; extract-rectangle-line stores lines into this list -;; to accumulate them for extract-rectangle and delete-extract-rectangle. -(defvar operate-on-rectangle-lines) - -;; ### NOTE: this function is untouched, but not used anymore apart from -;; `delete-whitespace-rectangle'. `apply-on-rectangle' is used instead. --dv +;; FIXME: this function should be replaced by `apply-on-rectangle' (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 @@ -88,12 +60,12 @@ Point is at the end of the segment of this line within the rectangle." (while (< (point) endlinepos) (let (startpos begextra endextra) (if coerce-tabs - (move-to-column-force startcol) + (move-to-column startcol t) (move-to-column startcol)) (setq begextra (- (current-column) startcol)) (setq startpos (point)) (if coerce-tabs - (move-to-column-force endcol) + (move-to-column endcol t) (move-to-column endcol)) ;; If we overshot, move back one character ;; so that endextra will be positive. @@ -107,13 +79,13 @@ Point is at the end of the segment of this line within the rectangle." (forward-line 1))) (- endcol startcol))) -;; 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 rectangle, plus ARGS extra arguments. Point is at the beginning of line when -the function is called." - (let (startcol startpt endcol endpt) +the function is called. +The final point after the last operation will be returned." + (let (startcol startpt endcol endpt final-point) (save-excursion (goto-char start) (setq startcol (current-column)) @@ -131,35 +103,30 @@ the function is called." (goto-char startpt) (while (< (point) endpt) (apply function startcol endcol args) + (setq final-point (point)) (forward-line 1))) - )) + final-point)) (defun delete-rectangle-line (startcol endcol fill) - (let ((pt (line-end-position))) - (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) - (if (and (not fill) (<= pt endcol)) - (delete-region (point) pt) - ;; else - (setq pt (point)) - (move-to-column-force endcol) - (delete-region pt (point)))) - )) + (when (= (move-to-column startcol (if fill t 'coerce)) startcol) + (delete-region (point) + (progn (move-to-column endcol 'coerce) + (point))))) (defun delete-extract-rectangle-line (startcol endcol lines fill) (let ((pt (point-at-eol))) - (if (< (move-to-column-force startcol (or fill 'coerce)) startcol) + (if (< (move-to-column startcol (if fill t 'coerce)) startcol) (setcdr lines (cons (spaces-string (- endcol startcol)) (cdr lines))) ;; else (setq pt (point)) - (move-to-column-force endcol) - (setcdr lines (cons (buffer-substring pt (point)) (cdr lines))) - (delete-region pt (point))) + (move-to-column endcol t) + (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines)))) )) -;; ### 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 +;; 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. (defun extract-rectangle-line (startcol endcol lines) (let (start end begextra endextra line) (move-to-column startcol) @@ -192,15 +159,11 @@ the function is called." (defconst spaces-strings '["" " " " " " " " " " " " " " " " "]) -;; this one is untouched --dv (defun spaces-string (n) + "Return a string with N spaces." (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))))) - + (make-string n ?\s))) + ;;;###autoload (defun delete-rectangle (start end &optional fill) "Delete (don't save) text in the region-rectangle. @@ -245,21 +208,39 @@ When called from a program the rectangle's corners are START and END. You might prefer to use `delete-extract-rectangle' from a program. With a prefix (or a FILL) argument, also fill lines where nothing has to be -deleted." - (interactive "*r\nP") - (when buffer-read-only - (setq killed-rectangle (extract-rectangle start end)) - (barf-if-buffer-read-only)) - (setq killed-rectangle (delete-extract-rectangle start end fill))) +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 deactivate-mark t) + (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))))))) + +;;;###autoload +(defun copy-rectangle-as-kill (start end) + "Copy the region-rectangle and save it as the last killed one." + (interactive "r") + (setq killed-rectangle (extract-rectangle start end)) + (setq deactivate-mark t) + (if (called-interactively-p 'interactive) + (indicate-copied-region (length (car killed-rectangle))))) -;; this one is untouched --dv ;;;###autoload (defun yank-rectangle () "Yank the last killed rectangle with upper left corner at point." (interactive "*") (insert-rectangle killed-rectangle)) -;; this one is untoutched --dv ;;;###autoload (defun insert-rectangle (rectangle) "Insert text of RECTANGLE with upper left corner at point. @@ -277,9 +258,9 @@ and point is at the lower right corner." (progn (forward-line 1) (or (bolp) (insert ?\n)) - (move-to-column-force insertcolumn))) + (move-to-column insertcolumn t))) (setq first nil) - (insert (car lines)) + (insert-for-yank (car lines)) (setq lines (cdr lines))))) ;;;###autoload @@ -290,24 +271,26 @@ The text previously in the region is not overwritten by the blanks, but instead winds up to the right of the rectangle. When called from a program the rectangle's corners are START and END. -With a prefix (or a FILL) argument, fill with blanks even if there is no text -on the right side of the rectangle." +With a prefix (or a FILL) argument, fill with blanks even if there is +no text on the right side of the rectangle." (interactive "*r\nP") (apply-on-rectangle 'open-rectangle-line start end fill) (goto-char start)) (defun open-rectangle-line (startcol endcol fill) - (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) + (when (= (move-to-column startcol (if fill t 'coerce)) startcol) (unless (and (not fill) (= (point) (point-at-eol))) (indent-to endcol)))) -(defun delete-whitespace-rectangle-line (startcol endcol fill) - (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) +(defun delete-whitespace-rectangle-line (startcol _endcol fill) + (when (= (move-to-column startcol (if fill t 'coerce)) startcol) (unless (= (point) (point-at-eol)) (delete-region (point) (progn (skip-syntax-forward " ") (point)))))) -;;;###autoload (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name +;;;###autoload +(defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name + ;;;###autoload (defun delete-whitespace-rectangle (start end &optional fill) "Delete all whitespace following a specified column in each line. @@ -320,13 +303,9 @@ With a prefix (or a FILL) argument, also fill too short lines." (interactive "*r\nP") (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill)) -;; not used any more --dv -;; string-rectangle uses this variable to pass the string -;; to string-rectangle-line. -(defvar string-rectangle-string) - +(defvar string-rectangle-history nil) (defun string-rectangle-line (startcol endcol string delete) - (move-to-column-force startcol) + (move-to-column startcol t) (if delete (delete-rectangle-line startcol endcol nil)) (insert string)) @@ -337,9 +316,19 @@ With a prefix (or a FILL) argument, also fill too short lines." The length of STRING need not be the same as the rectangle width. Called from a program, takes three args; START, END and STRING." - (interactive "*r\nsString rectangle: ") - (apply-on-rectangle 'string-rectangle-line start end string t)) + (interactive + (progn (barf-if-buffer-read-only) + (list + (region-beginning) + (region-end) + (read-string (format "String rectangle (default %s): " + (or (car string-rectangle-history) "")) + nil 'string-rectangle-history + (car string-rectangle-history))))) + (goto-char + (apply-on-rectangle 'string-rectangle-line start end string t))) +;;;###autoload (defalias 'replace-rectangle 'string-rectangle) ;;;###autoload @@ -349,7 +338,15 @@ Called from a program, takes three args; START, END and STRING." 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." - (interactive "*r\nsString insert rectangle: ") + (interactive + (progn (barf-if-buffer-read-only) + (list + (region-beginning) + (region-end) + (read-string (format "String insert rectangle (default %s): " + (or (car string-rectangle-history) "")) + nil 'string-rectangle-history + (car string-rectangle-history))))) (apply-on-rectangle 'string-rectangle-line start end string nil)) ;;;###autoload @@ -364,18 +361,56 @@ rectangle which were empty." (apply-on-rectangle 'clear-rectangle-line start end fill)) (defun clear-rectangle-line (startcol endcol fill) - (let ((pt (point-at-eol)) - spaces) - (when (= (move-to-column-force startcol (or fill 'coerce)) startcol) + (let ((pt (point-at-eol))) + (when (= (move-to-column startcol (if fill t 'coerce)) startcol) (if (and (not fill) (<= (save-excursion (goto-char pt) (current-column)) endcol)) (delete-region (point) pt) ;; else (setq pt (point)) - (move-to-column-force endcol) - (setq spaces (- (point) pt)) + (move-to-column endcol t) + (setq endcol (current-column)) (delete-region pt (point)) - (indent-to (+ (current-column) spaces)))))) + (indent-to endcol))))) + +;; Line numbers for `rectangle-number-line-callback'. +(defvar rectangle-number-line-counter) + +(defun rectangle-number-line-callback (start _end format-string) + (move-to-column start t) + (insert (format format-string rectangle-number-line-counter)) + (setq rectangle-number-line-counter + (1+ rectangle-number-line-counter))) + +(defun rectange--default-line-number-format (start end start-at) + (concat "%" + (int-to-string (length (int-to-string (+ (count-lines start end) + start-at)))) + "d ")) + +;;;###autoload +(defun rectangle-number-lines (start end start-at &optional format) + "Insert numbers in front of the region-rectangle. + +START-AT, if non-nil, should be a number from which to begin +counting. FORMAT, if non-nil, should be a format string to pass +to `format' along with the line count. When called interactively +with a prefix argument, prompt for START-AT and FORMAT." + (interactive + (if current-prefix-arg + (let* ((start (region-beginning)) + (end (region-end)) + (start-at (read-number "Number to count from: " 1))) + (list start end start-at + (read-string "Format string: " + (rectange--default-line-number-format + start end start-at)))) + (list (region-beginning) (region-end) 1 nil))) + (unless format + (setq format (rectange--default-line-number-format start end start-at))) + (let ((rectangle-number-line-counter start-at)) + (apply-on-rectangle 'rectangle-number-line-callback + start end format))) (provide 'rect)