X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/7be1c708c5abc7dea388d45454bd19bff07b7943..3a8b7013042adae3c27327a75662fd8e884d4896:/lisp/emulation/cua-rect.el

diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el
index 5d90ac694a..ea8b52476f 100644
--- a/lisp/emulation/cua-rect.el
+++ b/lisp/emulation/cua-rect.el
@@ -1,6 +1,6 @@
 ;;; cua-rect.el --- CUA unified rectangle support
 
-;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2015 Free Software Foundation, Inc.
 
 ;; Author: Kim F. Storm <storm@cua.dk>
 ;; Keywords: keyboard emulations convenience CUA
@@ -21,7 +21,7 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
-;;; Acknowledgements
+;;; Acknowledgments
 
 ;; The rectangle handling and display code borrows from the standard
 ;; GNU emacs rect.el package and the rect-mark.el package by Rick
@@ -31,8 +31,7 @@
 
 ;;; Code:
 
-(eval-when-compile
-  (require 'cua-base))
+(require 'cua-base)
 
 ;;; Rectangle support
 
@@ -79,7 +78,7 @@
       (push (list 'apply 0 s e
 		  'cua--rect-undo-handler
 		  (copy-sequence cua--rectangle) t s e)
-	  buffer-undo-list))))
+            buffer-undo-list))))
 
 (defun cua--rect-undo-handler (rect on s e)
   (if (setq on (not on))
@@ -90,6 +89,21 @@
 	      'cua--rect-undo-handler rect on s e)
 	buffer-undo-list))
 
+;;;###autoload
+(define-minor-mode cua-rectangle-mark-mode
+  "Toggle the region as rectangular.
+Activates the region if needed.  Only lasts until the region is deactivated."
+  :keymap cua--rectangle-keymap
+  (cond
+   (cua-rectangle-mark-mode
+    (add-hook 'deactivate-mark-hook
+              (lambda () (cua-rectangle-mark-mode -1)))
+    (add-hook 'post-command-hook #'cua--rectangle-post-command nil t)
+    (cua-set-rectangle-mark))
+   (t
+    (cua--deactivate-rectangle)
+    (remove-hook 'post-command-hook #'cua--rectangle-post-command t))))
+
 ;;; Rectangle geometry
 
 (defun cua--rectangle-top (&optional val)
@@ -462,10 +476,10 @@ If command is repeated at same position, delete the rectangle."
         (cua--deactivate))
     (cua-mouse-resize-rectangle event)
     (let ((cua-keep-region-after-copy t))
-      (cua-copy-rectangle arg)
+      (cua-copy-region arg)
       (setq cua--mouse-last-pos (cons (point) cua--last-killed-rectangle)))))
 
-(defun cua--mouse-ignore (event)
+(defun cua--mouse-ignore (_event)
   (interactive "e")
   (setq this-command last-command))
 
@@ -609,12 +623,12 @@ If command is repeated at same position, delete the rectangle."
   (let ((lines 0))
     (if (not (cua--rectangle-virtual-edges))
 	(cua--rectangle-operation nil nil t 2 t
-	  (lambda (s e l r v)
+	  (lambda (s e _l _r _v)
             (setq lines (1+ lines))
             (if (and (> e s) (<= e (point-max)))
                 (delete-region s e))))
       (cua--rectangle-operation nil 1 t nil t
-	(lambda (s e l r v)
+	(lambda (s e _l _r _v)
 	   (setq lines (1+ lines))
 	   (when (and (> e s) (<= e (point-max)))
 	     (delete-region s e)))))
@@ -624,10 +638,10 @@ If command is repeated at same position, delete the rectangle."
   (let (rect)
     (if (not (cua--rectangle-virtual-edges))
 	(cua--rectangle-operation nil nil nil nil nil ; do not tabify
-	  (lambda (s e l r)
+	  (lambda (s e _l _r)
 	     (setq rect (cons (cua--filter-buffer-noprops s e) rect))))
       (cua--rectangle-operation nil 1 nil nil nil ; do not tabify
-	(lambda (s e l r v)
+	(lambda (s e l r _v)
 	   (let ((copy t) (bs 0) (as 0) row)
 	     (if (= s e) (setq e (1+ e)))
 	     (goto-char s)
@@ -709,30 +723,34 @@ If command is repeated at same position, delete the rectangle."
                    killed-rectangle "")))))
 
 (defun cua--activate-rectangle ()
-  ;; Turn on rectangular marking mode by disabling transient mark mode
-  ;; and manually handling highlighting from a post command hook.
+  ;; Set cua--rectangle to indicate we're marking a rectangle.
   ;; Be careful if we are already marking a rectangle.
   (setq cua--rectangle
-        (if (and cua--last-rectangle
+        (or (and cua--last-rectangle
                  (eq (car cua--last-rectangle) (current-buffer))
-                 (eq (car (cdr cua--last-rectangle)) (point)))
-            (cdr (cdr cua--last-rectangle))
-          (cua--rectangle-get-corners))
+                 (eq (car (cdr cua--last-rectangle)) (point))
+                 (cdr (cdr cua--last-rectangle)))
+            (cua--rectangle-get-corners))
         cua--status-string (if (cua--rectangle-virtual-edges) " [R]" "")
-        cua--last-rectangle nil))
+        cua--last-rectangle nil)
+  (activate-mark))
 
 ;; (defvar cua-save-point nil)
 
 (defun cua--deactivate-rectangle ()
   ;; This is used to clean up after `cua--activate-rectangle'.
-  (mapc (function delete-overlay) cua--rectangle-overlays)
+  (mapc #'delete-overlay cua--rectangle-overlays)
   (setq cua--last-rectangle (cons (current-buffer)
                                   (cons (point) ;; cua-save-point
                                         cua--rectangle))
         cua--rectangle nil
         cua--rectangle-overlays nil
         cua--status-string nil
-        cua--mouse-last-pos nil))
+        cua--mouse-last-pos nil)
+  ;; FIXME: This call to cua-rectangle-mark-mode is a workaround.
+  ;; Deactivation can happen in various different ways, and we
+  ;; currently don't handle them all in a coherent way.
+  (if cua-rectangle-mark-mode (cua-rectangle-mark-mode -1)))
 
 (defun cua--highlight-rectangle ()
   ;; This function is used to highlight the rectangular region.
@@ -741,7 +759,7 @@ If command is repeated at same position, delete the rectangle."
   ;; We try to reuse overlays where possible because this is more efficient
   ;; and results in less flicker.
   ;; If cua--rectangle-virtual-edges is nil and the buffer contains tabs or short lines,
-  ;; the higlighted region may not be perfectly rectangular.
+  ;; the highlighted region may not be perfectly rectangular.
   (let ((deactivate-mark deactivate-mark)
         (old cua--rectangle-overlays)
         (new nil)
@@ -776,7 +794,7 @@ If command is repeated at same position, delete the rectangle."
 			       (make-string
 				(- l cl0 (if (and (= le pl) (/= le lb)) 1 0))
 				(if cua--virtual-edges-debug ?. ?\s))
-			       'face (or (get-text-property (1- s) 'face) 'default)))
+			       'face (or (get-text-property (max (1- s) (point-min)) 'face) 'default)))
 		     (if (/= pl le)
 			 (setq s (1- s))))
 		   (cond
@@ -840,7 +858,7 @@ If command is repeated at same position, delete the rectangle."
         (pad (cua--rectangle-virtual-edges))
         indent)
     (cua--rectangle-operation (if clear 'clear 'corners) nil t pad nil
-      (lambda (s e l r)
+      (lambda (_s _e l _r)
          (move-to-column col pad)
          (if (and (eolp)
                   (< (current-column) col))
@@ -878,8 +896,6 @@ With prefix argument, activate previous rectangle if possible."
           (push-mark nil nil t)))
     (cua--activate-rectangle)
     (cua--rectangle-set-corners)
-    (setq mark-active t
-          cua--explicit-region-start t)
     (if cua-enable-rectangle-auto-help
         (cua-help-for-rectangle t))))
 
@@ -887,8 +903,7 @@ With prefix argument, activate previous rectangle if possible."
   "Cancel current rectangle."
   (interactive)
   (when cua--rectangle
-    (setq mark-active nil
-          cua--explicit-region-start nil)
+    (setq mark-active nil)
     (cua--deactivate-rectangle)))
 
 (defun cua-toggle-rectangle-mark ()
@@ -905,10 +920,10 @@ With prefix argument, activate previous rectangle if possible."
         (cua-help-for-region t))))
 
 (defun cua-restrict-regexp-rectangle (arg)
-  "Restrict rectangle to lines (not) matching REGEXP.
-With prefix argument, the toggle restriction."
+  "Restrict rectangle to lines (not) matching regexp.
+With prefix argument, toggle restriction."
   (interactive "P")
-  (let ((r (cua--rectangle-restriction)) regexp)
+  (let ((r (cua--rectangle-restriction)))
     (if (and r (null (car (cdr r))))
       (if arg
           (cua--rectangle-restriction (car r) nil (not (car (cdr (cdr r)))))
@@ -919,9 +934,9 @@ With prefix argument, the toggle restriction."
 
 (defun cua-restrict-prefix-rectangle (arg)
   "Restrict rectangle to lines (not) starting with CHAR.
-With prefix argument, the toggle restriction."
+With prefix argument, toggle restriction."
   (interactive "P")
-  (let ((r (cua--rectangle-restriction)) regexp)
+  (let ((r (cua--rectangle-restriction)))
     (if (and r (car (cdr r)))
       (if arg
           (cua--rectangle-restriction (car r) t (not (car (cdr (cdr r)))))
@@ -946,32 +961,6 @@ With prefix argument, the toggle restriction."
   (interactive)
   (cua--rectangle-move 'right))
 
-(defun cua-copy-rectangle (arg)
-  (interactive "P")
-  (setq arg (cua--prefix-arg arg))
-  (cua--copy-rectangle-as-kill arg)
-  (if cua-keep-region-after-copy
-      (cua--keep-active)
-    (cua--deactivate)))
-
-(defun cua-cut-rectangle (arg)
-  (interactive "P")
-  (if buffer-read-only
-      (cua-copy-rectangle arg)
-    (setq arg (cua--prefix-arg arg))
-    (goto-char (min (mark) (point)))
-    (cua--copy-rectangle-as-kill arg)
-    (cua--delete-rectangle))
-  (cua--deactivate))
-
-(defun cua-delete-rectangle ()
-  (interactive)
-  (goto-char (min (point) (mark)))
-  (if cua-delete-copy-to-register-0
-      (set-register ?0 (cua--extract-rectangle)))
-  (cua--delete-rectangle)
-  (cua--deactivate))
-
 (defun cua-rotate-rectangle ()
   (interactive)
   (cua--rectangle-corner (if (= (cua--rectangle-left) (cua--rectangle-right)) 0 1))
@@ -1000,7 +989,7 @@ The text previously in the region is not overwritten by the blanks,
 but instead winds up to the right of the rectangle."
   (interactive)
   (cua--rectangle-operation 'corners nil t 1 nil
-   (lambda (s e l r)
+   (lambda (_s _e l r)
       (skip-chars-forward " \t")
       (let ((ws (- (current-column) l))
             (p (point)))
@@ -1015,7 +1004,7 @@ at that column is deleted.
 With prefix arg, also delete whitespace to the left of that column."
   (interactive "P")
   (cua--rectangle-operation 'clear nil t 1 nil
-   (lambda (s e l r)
+   (lambda (s _e _l _r)
       (when arg
         (skip-syntax-backward " " (line-beginning-position))
         (setq s (point)))
@@ -1027,7 +1016,7 @@ With prefix arg, also delete whitespace to the left of that column."
 The text previously in the rectangle is overwritten by the blanks."
   (interactive)
   (cua--rectangle-operation 'keep nil nil 1 nil
-   (lambda (s e l r)
+   (lambda (s e _l _r)
       (goto-char e)
       (skip-syntax-forward " " (line-end-position))
       (setq e (point))
@@ -1040,20 +1029,19 @@ The text previously in the rectangle is overwritten by the blanks."
 (defun cua-align-rectangle ()
   "Align rectangle lines to left column."
   (interactive)
-  (let (x)
-    (cua--rectangle-operation 'clear nil t t nil
-     (lambda (s e l r)
-        (let ((b (line-beginning-position)))
-          (skip-syntax-backward "^ " b)
-          (skip-syntax-backward " " b)
-          (setq s (point)))
-        (skip-syntax-forward " " (line-end-position))
-        (delete-region s (point))
-        (indent-to l))
-     (lambda (l r)
-        (move-to-column l)
-        ;; (setq cua-save-point (point))
-        ))))
+  (cua--rectangle-operation 'clear nil t t nil
+   (lambda (s _e l _r)
+      (let ((b (line-beginning-position)))
+	(skip-syntax-backward "^ " b)
+	(skip-syntax-backward " " b)
+	(setq s (point)))
+      (skip-syntax-forward " " (line-end-position))
+      (delete-region s (point))
+      (indent-to l))
+   (lambda (l _r)
+      (move-to-column l)
+      ;; (setq cua-save-point (point))
+      )))
 
 (declare-function cua--cut-rectangle-to-global-mark  "cua-gmrk" (as-text))
 (declare-function cua--copy-rectangle-to-global-mark "cua-gmrk" (as-text))
@@ -1087,7 +1075,7 @@ The text previously in the rectangle is overwritten by the blanks."
 The length of STRING need not be the same as the rectangle width."
   (interactive "sString rectangle: ")
   (cua--rectangle-operation 'keep nil t t nil
-     (lambda (s e l r)
+     (lambda (s e l _r)
         (delete-region s e)
         (skip-chars-forward " \t")
         (let ((ws (- (current-column) l)))
@@ -1095,7 +1083,7 @@ The length of STRING need not be the same as the rectangle width."
           (insert string)
           (indent-to (+ (current-column) ws))))
      (unless (cua--rectangle-restriction)
-       (lambda (l r)
+       (lambda (l _r)
           (cua--rectangle-right (max l (+ l (length string) -1)))))))
 
 (defun cua-fill-char-rectangle (character)
@@ -1113,7 +1101,7 @@ The length of STRING need not be the same as the rectangle width."
   (if buffer-read-only
       (message "Cannot replace in read-only buffer")
     (cua--rectangle-operation 'keep nil t 1 nil
-     (lambda (s e l r)
+     (lambda (_s e _l _r)
         (if (re-search-forward regexp e t)
             (replace-match newtext nil nil))))))
 
@@ -1121,7 +1109,7 @@ The length of STRING need not be the same as the rectangle width."
   "Increment each line of CUA rectangle by prefix amount."
   (interactive "p")
   (cua--rectangle-operation 'keep nil t 1 nil
-     (lambda (s e l r)
+     (lambda (_s e _l _r)
         (cond
          ((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t)
           (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1)))
@@ -1154,14 +1142,14 @@ The numbers are formatted according to the FORMAT string."
       (setq format cua--rectangle-seq-format)
     (setq cua--rectangle-seq-format format))
   (cua--rectangle-operation 'clear nil t 1 nil
-     (lambda (s e l r)
+     (lambda (s e _l _r)
          (delete-region s e)
          (insert (format format first))
          (setq first (+ first incr)))))
 
 (defmacro cua--convert-rectangle-as (command tabify)
   `(cua--rectangle-operation 'clear nil nil nil ,tabify
-    (lambda (s e l r)
+    (lambda (s e _l _r)
        (,command s e))))
 
 (defun cua-upcase-rectangle ()
@@ -1218,7 +1206,7 @@ The numbers are formatted according to the FORMAT string."
       (if cua--debug
 	  (print z auxbuf))
       (cua--rectangle-operation nil nil t pad nil
-        (lambda (s e l r)
+        (lambda (s e l _r)
            (let (cc)
              (goto-char e)
              (skip-chars-forward " \t")
@@ -1249,7 +1237,7 @@ The numbers are formatted according to the FORMAT string."
 
 (put 'cua--rectangle-aux-replace 'lisp-indent-function 4)
 
-(defun cua--left-fill-rectangle (start end)
+(defun cua--left-fill-rectangle (_start _end)
   (beginning-of-line)
   (while (< (point) (point-max))
     (delete-horizontal-space nil)
@@ -1258,7 +1246,7 @@ The numbers are formatted according to the FORMAT string."
   (untabify (point-min) (point-max)))
 
 (defun cua-text-fill-rectangle (width text)
-  "Replace rectagle with filled TEXT read from minibuffer.
+  "Replace rectangle with filled TEXT read from minibuffer.
 A numeric prefix argument is used a new width for the filled rectangle."
   (interactive (list
                 (prefix-numeric-value current-prefix-arg)
@@ -1269,7 +1257,7 @@ A numeric prefix argument is used a new width for the filled rectangle."
     (lambda () (insert text))))
 
 (defun cua-refill-rectangle (width)
-  "Fill contents of current rectagle.
+  "Fill contents of current rectangle.
 A numeric prefix argument is used as new width for the filled rectangle."
   (interactive "P")
   (cua--rectangle-aux-replace
@@ -1298,7 +1286,7 @@ With prefix arg, replace rectangle with output from command."
   "Remove the first line of the rectangle and scroll remaining lines up."
   (interactive)
   (cua--rectangle-aux-replace 0 t t t t
-    (lambda (s e)
+    (lambda (s _e)
        (if (= (forward-line 1) 0)
            (delete-region s (point))))))
 
@@ -1307,7 +1295,7 @@ With prefix arg, replace rectangle with output from command."
 The remaining lines are scrolled down, losing the last line."
   (interactive)
   (cua--rectangle-aux-replace 0 t t t t
-    (lambda (s e)
+    (lambda (s _e)
        (goto-char s)
        (insert "\n"))))
 
@@ -1337,7 +1325,7 @@ With prefix arg, indent to that column."
         (pad (cua--rectangle-virtual-edges))
         indent)
     (cua--rectangle-operation 'corners nil t pad nil
-     (lambda (s e l r)
+     (lambda (_s _e l r)
         (move-to-column
          (if (cua--rectangle-right-side t)
              (max (1+ r) col) l)
@@ -1404,6 +1392,38 @@ With prefix arg, indent to that column."
     (goto-char cua--rect-undo-set-point)
     (setq cua--rect-undo-set-point nil)))
 
+(add-function :around region-extract-function
+              #'cua--rectangle-region-extract)
+(add-function :around redisplay-highlight-region-function
+              #'cua--rectangle-highlight-for-redisplay)
+
+(defun cua--rectangle-highlight-for-redisplay (orig &rest args)
+  (if (not cua--rectangle) (apply orig args)
+    ;; When cua--rectangle is active, just don't highlight at all, since we
+    ;; already do it elsewhere.
+    (funcall redisplay-unhighlight-region-function (nth 3 args))))
+
+(defun cua--rectangle-region-extract (orig &optional delete)
+  (cond
+   ((not cua--rectangle) (funcall orig delete))
+   ((eq delete 'delete-only) (cua--delete-rectangle))
+   (t
+    (let* ((strs (cua--extract-rectangle))
+           (str (mapconcat #'identity strs "\n")))
+      (if delete (cua--delete-rectangle))
+      (setq killed-rectangle strs)
+      (setq cua--last-killed-rectangle
+            (cons (and kill-ring (car kill-ring)) killed-rectangle))
+      (when (eq last-command 'kill-region)
+        ;; Try to prevent kill-region from appending this to some
+        ;; earlier element.
+        (setq last-command 'kill-region-dont-append))
+      (when strs
+        (put-text-property 0 (length str) 'yank-handler
+                           `(rectangle--insert-for-yank ,strs t)
+                           str)
+        str)))))
+
 ;;; Initialization
 
 (defun cua--rect-M/H-key (key cmd)
@@ -1416,14 +1436,12 @@ With prefix arg, indent to that column."
     (cua--rect-M/H-key ?\s			       'cua-clear-rectangle-mark)
     (cua--M/H-key cua--region-keymap ?\s	       'cua-toggle-rectangle-mark))
 
-  (define-key cua--rectangle-keymap [remap copy-region-as-kill] 'cua-copy-rectangle)
-  (define-key cua--rectangle-keymap [remap kill-ring-save]      'cua-copy-rectangle)
-  (define-key cua--rectangle-keymap [remap kill-region]         'cua-cut-rectangle)
-  (define-key cua--rectangle-keymap [remap delete-char]         'cua-delete-rectangle)
   (define-key cua--rectangle-keymap [remap set-mark-command]    'cua-toggle-rectangle-mark)
 
   (define-key cua--rectangle-keymap [remap forward-char]        'cua-resize-rectangle-right)
+  (define-key cua--rectangle-keymap [remap right-char]          'cua-resize-rectangle-right)
   (define-key cua--rectangle-keymap [remap backward-char]       'cua-resize-rectangle-left)
+  (define-key cua--rectangle-keymap [remap left-char]           'cua-resize-rectangle-left)
   (define-key cua--rectangle-keymap [remap next-line]           'cua-resize-rectangle-down)
   (define-key cua--rectangle-keymap [remap previous-line]       'cua-resize-rectangle-up)
   (define-key cua--rectangle-keymap [remap end-of-line]         'cua-resize-rectangle-eol)
@@ -1439,7 +1457,6 @@ With prefix arg, indent to that column."
   (define-key cua--rectangle-keymap [remap backward-delete-char] 'cua-delete-char-rectangle)
   (define-key cua--rectangle-keymap [remap backward-delete-char-untabify] 'cua-delete-char-rectangle)
   (define-key cua--rectangle-keymap [remap self-insert-command]	 'cua-insert-char-rectangle)
-  (define-key cua--rectangle-keymap [remap self-insert-iso]	 'cua-insert-char-rectangle)
 
   ;; Catch self-inserting characters which are "stolen" by other modes
   (define-key cua--rectangle-keymap [t]