X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/666b903b912ca0aa2b1a034859b752b04f03141a..d4aca72ead4c1e53819e6e3249e26400a9879a0e:/lisp/emulation/cua-rect.el diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 4286afba93..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-2012 Free Software Foundation, Inc. +;; Copyright (C) 1997-2015 Free Software Foundation, Inc. ;; Author: Kim F. Storm ;; 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 . -;;; 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,7 +476,7 @@ 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) @@ -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. @@ -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 @@ -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 () @@ -946,32 +961,6 @@ With prefix argument, 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)) @@ -1403,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) @@ -1415,15 +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 delete-forward-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]