*** empty log message ***

[bpt/emacs.git] / lisp / rect.el

diff --git a/lisp/rect.el b/lisp/rect.el
index 3c71173..eb188fc 100644 (file)
--- 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, 2000, 2001, 2002, 2003, 2004
+;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

 
 

-;; Maintainer: Didier Verna <verna@inf.enst.fr>
+;; Maintainer: Didier Verna <didier@xemacs.org>

 ;; Keywords: internal
 
 ;; This file is part of GNU Emacs.
 
 ;; Keywords: internal
 
 ;; 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
 ;; 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
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of


@@ -18,9 +19,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; 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 <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -28,30 +27,30 @@
 ;; in the Emacs manual.
 
 ;; ### NOTE: this file has been almost completely rewritten by Didier Verna
 ;; in the Emacs manual.
 
 ;; ### NOTE: this file has been almost completely rewritten by Didier Verna

-;; <verna@inf.enst.fr> in July 1999. The purpose of this rewrite is to be less
+;; <didier@xemacs.org> 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.
 
 ;; intrusive and fill lines with whitespaces only when needed. A few functions
 ;; are untouched though, as noted above their definition.
 

+;;; Global key bindings
+
+;;;###autoload (define-key ctl-x-r-map "c" 'clear-rectangle)
+;;;###autoload (define-key ctl-x-r-map "k" 'kill-rectangle)
+;;;###autoload (define-key ctl-x-r-map "d" 'delete-rectangle)
+;;;###autoload (define-key ctl-x-r-map "y" 'yank-rectangle)
+;;;###autoload (define-key ctl-x-r-map "o" 'open-rectangle)
+;;;###autoload (define-key ctl-x-r-map "t" 'string-rectangle)

 
 ;;; Code:
 
 ;;;###autoload
 (defun move-to-column-force (column &optional flag)
 
 ;;; 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.
-
+  "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."
 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))
+  (move-to-column column (or flag t)))
+
+;;;###autoload
+(make-obsolete 'move-to-column-force 'move-to-column "21.2")

 
 ;; not used any more --dv
 ;; extract-rectangle-line stores lines into this list
 
 ;; not used any more --dv
 ;; extract-rectangle-line stores lines into this list


@@ -88,12 +87,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
      (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 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.
           (move-to-column endcol))
         ;; If we overshot, move back one character
         ;; so that endextra will be positive.


@@ -135,26 +134,20 @@ the function is called."
     ))
 
 (defun delete-rectangle-line (startcol endcol fill)
     ))
 
 (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)))
 
 (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))
        (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
     ))
 
 ;; ### NOTE: this is actually the only function that needs to do complicated


@@ -194,13 +187,10 @@ the function is called."
 
 ;; this one is untouched --dv
 (defun spaces-string (n)
 
 ;; this one is untouched --dv
 (defun spaces-string (n)

+  "Return a string with N spaces."

   (if (<= n 8) (aref spaces-strings 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)))))
-    
+    (make-string n ?\s)))
+

 ;;;###autoload
 (defun delete-rectangle (start end &optional fill)
   "Delete (don't save) text in the region-rectangle.
 ;;;###autoload
 (defun delete-rectangle (start end &optional fill)
   "Delete (don't save) text in the region-rectangle.


@@ -245,12 +235,22 @@ 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
 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 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)))))))

 
 ;; this one is untouched --dv
 ;;;###autoload
 
 ;; this one is untouched --dv
 ;;;###autoload


@@ -277,9 +277,9 @@ and point is at the lower right corner."
          (progn
           (forward-line 1)
           (or (bolp) (insert ?\n))
          (progn
           (forward-line 1)
           (or (bolp) (insert ?\n))

-          (move-to-column-force insertcolumn)))
+          (move-to-column insertcolumn t)))

       (setq first nil)
       (setq first nil)

-      (insert (car lines))
+      (insert-for-yank (car lines))

       (setq lines (cdr lines)))))
 
 ;;;###autoload
       (setq lines (cdr lines)))))
 
 ;;;###autoload


@@ -290,24 +290,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.
 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)
   (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)
     (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)
+  (when (= (move-to-column startcol (if fill t 'coerce)) startcol)

     (unless (= (point) (point-at-eol))
       (delete-region (point) (progn (skip-syntax-forward " ") (point))))))
 
     (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.
 ;;;###autoload
 (defun delete-whitespace-rectangle (start end &optional fill)
   "Delete all whitespace following a specified column in each line.


@@ -324,9 +326,9 @@ With a prefix (or a FILL) argument, also fill too short lines."
 ;; string-rectangle uses this variable to pass the string
 ;; to string-rectangle-line.
 (defvar string-rectangle-string)
 ;; 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)
 (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))
   (if delete
       (delete-rectangle-line startcol endcol nil))
   (insert string))


@@ -337,9 +339,18 @@ 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."
 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: ")
+  (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)))))

   (apply-on-rectangle 'string-rectangle-line start end string t))
 
   (apply-on-rectangle 'string-rectangle-line start end string t))
 

+;;;###autoload

 (defalias 'replace-rectangle 'string-rectangle)
 
 ;;;###autoload
 (defalias 'replace-rectangle 'string-rectangle)
 
 ;;;###autoload


@@ -349,7 +360,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."
 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
   (apply-on-rectangle 'string-rectangle-line start end string nil))
 
 ;;;###autoload


@@ -364,19 +383,19 @@ rectangle which were empty."
   (apply-on-rectangle 'clear-rectangle-line start end fill))
 
 (defun clear-rectangle-line (startcol endcol fill)
   (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))
       (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))
        (delete-region pt (point))

-       (indent-to (+ (current-column) spaces))))))
+       (indent-to endcol)))))

 
 (provide 'rect)
 
 
 (provide 'rect)
 

+;; arch-tag: 178847b3-1f50-4b03-83de-a6e911cc1d16

 ;;; rect.el ends here
 ;;; rect.el ends here