;;; 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
;; 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
;;; Code:
-(eval-when-compile
- (require 'cua-base))
+(require 'cua-base)
;;; Rectangle support
(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))
'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)
(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))
(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)))))
(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)
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.
;; 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)
(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
(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))
(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))))
"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 ()
(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)))))
(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)))))
(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))
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)))
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)))
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))
(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))
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)))
(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)
(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))))))
"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)))
(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 ()
(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")
(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)
(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)
(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
"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))))))
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"))))
(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)
(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)
(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)
(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]