diff options
Diffstat (limited to 'lisp/emulation')
| -rw-r--r-- | lisp/emulation/cua-base.el | 91 | ||||
| -rw-r--r-- | lisp/emulation/cua-rect.el | 417 |
2 files changed, 327 insertions, 181 deletions
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index b39945c7712..fb3c537936f 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -141,30 +141,39 @@ ;; completely separate set of "rectangle commands" [C-x r ...] on the ;; region to copy, kill, fill a.s.o. the virtual rectangle. ;; -;; cua-mode's superior rectangle support is based on using a true visual -;; representation of the selected rectangle. To start a rectangle, use -;; [S-return] and extend it using the normal movement keys (up, down, -;; left, right, home, end, C-home, C-end). Once the rectangle has the -;; desired size, you can cut or copy it using C-x and C-c (or C-w and M-w), -;; and you can subsequently insert it - as a rectangle - using C-v (or -;; C-y). So the only new command you need to know to work with -;; cua-mode rectangles is S-return! +;; cua-mode's superior rectangle support uses a true visual +;; representation of the selected rectangle, i.e. it highlights the +;; actual part of the buffer that is currently selected as part of the +;; rectangle. Unlike emacs' traditional rectangle commands, the +;; selected rectangle always as straight left and right edges, even +;; when those are in the middle of a TAB character or beyond the end +;; of the current line. And it does this without actually modifying +;; the buffer contents (it uses display overlays to visualize the +;; virtual dimensions of the rectangle). +;; +;; This means that cua-mode's rectangles are not limited to the actual +;; contents of the buffer, so if the cursor is currently at the end of a +;; short line, you can still extend the rectangle to include more columns +;; of longer lines in the same rectangle. And you can also have the +;; left edge of a rectangle start in the middle of a TAB character. +;; Sounds strange? Try it! +;; +;; To start a rectangle, use [S-return] and extend it using the normal +;; movement keys (up, down, left, right, home, end, C-home, +;; C-end). Once the rectangle has the desired size, you can cut or +;; copy it using C-x and C-c (or C-w and M-w), and you can +;; subsequently insert it - as a rectangle - using C-v (or C-y). So +;; the only new command you need to know to work with cua-mode +;; rectangles is S-return! ;; ;; Normally, when you paste a rectangle using C-v (C-y), each line of ;; the rectangle is inserted into the existing lines in the buffer. ;; If overwrite-mode is active when you paste a rectangle, it is ;; inserted as normal (multi-line) text. ;; -;; Furthermore, cua-mode's rectangles are not limited to the actual -;; contents of the buffer, so if the cursor is currently at the end of a -;; short line, you can still extend the rectangle to include more columns -;; of longer lines in the same rectangle. Sounds strange? Try it! -;; -;; You can enable padding for just this rectangle by pressing [M-p]; -;; this works like entering `picture-mode' where the tabs and spaces -;; are automatically converted/inserted to make the rectangle truly -;; rectangular. Or you can do it for all rectangles by setting the -;; `cua-auto-expand-rectangles' variable. +;; If you prefer the traditional rectangle marking (i.e. don't want +;; straight edges), [M-p] toggles this for the current rectangle, +;; or you can customize cua-virtual-rectangle-edges. ;; And there's more: If you want to extend or reduce the size of the ;; rectangle in one of the other corners of the rectangle, just use @@ -204,8 +213,8 @@ ;; a supplied format string (prompt) ;; [M-o] opens the rectangle by moving the highlighted text to the ;; right of the rectangle and filling the rectangle with blanks. -;; [M-p] toggles rectangle padding, i.e. insert tabs and spaces to -;; make rectangles truly rectangular +;; [M-p] toggles virtual straight rectangle edges +;; [M-P] inserts tabs and spaces (padding) to make real straight edges ;; [M-q] performs text filling on the rectangle ;; [M-r] replaces REGEXP (prompt) by STRING (prompt) in rectangle ;; [M-R] reverse the lines in the rectangle @@ -347,14 +356,27 @@ managers, so try setting this to nil, if prefix override doesn't work." ;;; Rectangle Customization -(defcustom cua-auto-expand-rectangles nil - "*If non-nil, rectangles are padded with spaces to make straight edges. -This implies modifying buffer contents by expanding tabs and inserting spaces. -Consequently, this is inhibited in read-only buffers. -Can be toggled by [M-p] while the rectangle is active," +(defcustom cua-virtual-rectangle-edges t + "*If non-nil, rectangles have virtual straight edges. +Note that although rectangles are always DISPLAYED with straight edges, the +buffer is NOT modified, until you execute a command that actually modifies it. +\[M-p] toggles this feature when a rectangle is active." :type 'boolean :group 'cua) +(defcustom cua-auto-tabify-rectangles 1000 + "*If non-nil, automatically tabify after rectangle commands. +This basically means that `tabify' is applied to all lines that +are modified by inserting or deleting a rectangle. If value is +an integer, cua will look for existing tabs in a region around +the rectangle, and only do the conversion if any tabs are already +present. The number specifies then number of characters before +and after the region marked by the rectangle to search." + :type '(choice (number :tag "Auto detect (limit)") + (const :tag "Disabled" nil) + (other :tag "Enabled" t)) + :group 'cua) + (defcustom cua-enable-rectangle-auto-help t "*If non-nil, automatically show help for region, rectangle and global mark." :type 'boolean @@ -412,7 +434,6 @@ Can be toggled by [M-p] while the rectangle is active," (frame-parameter nil 'cursor-color) "red") "Normal (non-overwrite) cursor color. -Also used to indicate that rectangle padding is not in effect. Default is to load cursor color from initial or default frame parameters. If the value is a COLOR name, then only the `cursor-color' attribute will be @@ -462,7 +483,6 @@ a cons (TYPE . COLOR), then both properties are affected." (defcustom cua-overwrite-cursor-color "yellow" "*Cursor color used when overwrite mode is set, if non-nil. -Also used to indicate that rectangle padding is in effect. Only used when `cua-enable-cursor-indications' is non-nil. If the value is a COLOR name, then only the `cursor-color' attribute will be @@ -806,7 +826,8 @@ If global mark is active, copy from register or one character." (interactive "P") (setq arg (cua--prefix-arg arg)) (let ((regtxt (and cua--register (get-register cua--register))) - (count (prefix-numeric-value arg))) + (count (prefix-numeric-value arg)) + paste-column paste-lines) (cond ((and cua--register (not regtxt)) (message "Nothing in register %c" cua--register)) @@ -825,7 +846,12 @@ If global mark is active, copy from register or one character." ;; the same region that we are going to delete. ;; That would make yank a no-op. (if cua--rectangle - (cua--delete-rectangle) + (progn + (goto-char (min (mark) (point))) + (setq paste-column (cua--rectangle-left)) + (setq paste-lines (cua--delete-rectangle)) + (if (= paste-lines 1) + (setq paste-lines nil))) ;; paste all (if (string= (buffer-substring (point) (mark)) (car kill-ring)) (current-kill 1)) @@ -843,7 +869,8 @@ If global mark is active, copy from register or one character." (setq this-command 'cua--paste-rectangle) (undo-boundary) (setq buffer-undo-list (cons pt buffer-undo-list))) - (cua--insert-rectangle (cdr cua--last-killed-rectangle)) + (cua--insert-rectangle (cdr cua--last-killed-rectangle) + nil paste-column paste-lines) (if arg (goto-char pt)))) (t (yank arg))))))) @@ -1033,9 +1060,7 @@ If ARG is the atom `-', scroll upward by nearly full screen." ((and buffer-read-only cua-read-only-cursor-color) cua-read-only-cursor-color) - ((and cua-overwrite-cursor-color - (or overwrite-mode - (and cua--rectangle (cua--rectangle-padding)))) + ((and cua-overwrite-cursor-color overwrite-mode) cua-overwrite-cursor-color) (t cua-normal-cursor-color))) (color (if (consp cursor) (cdr cursor) cursor)) diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 965fe63bced..3270b7fd62c 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -44,10 +44,10 @@ (require 'rect) ;; If non-nil, restrict current region to this rectangle. -;; Value is a vector [top bot left right corner ins pad select]. +;; Value is a vector [top bot left right corner ins virt select]. ;; CORNER specifies currently active corner 0=t/l 1=t/r 2=b/l 3=b/r. ;; INS specifies whether to insert on left(nil) or right(t) side. -;; If PAD is non-nil, tabs are converted to spaces when necessary. +;; If VIRT is non-nil, virtual straight edges are enabled. ;; If SELECT is a regexp, only lines starting with that regexp are affected.") (defvar cua--rectangle nil) (make-variable-buffer-local 'cua--rectangle) @@ -65,6 +65,12 @@ (defvar cua--rectangle-overlays nil) (make-variable-buffer-local 'cua--rectangle-overlays) +(defvar cua--overlay-keymap + (let ((map (make-sparse-keymap))) + (define-key map "\r" 'cua-rotate-rectangle))) + +(defvar cua--virtual-edges-debug nil) + ;; Per-buffer CUA mode undo list. (defvar cua--undo-list nil) (make-variable-buffer-local 'cua--undo-list) @@ -97,7 +103,7 @@ Knows about CUA rectangle highlighting in addition to standard undo." (defvar cua--tidy-undo-counter 0 "Number of times `cua--tidy-undo-lists' have run successfully.") -;; Clean out danling entries from cua's undo list. +;; Clean out dangling entries from cua's undo list. ;; Since this list contains pointers into the standard undo list, ;; such references are only meningful as undo information if the ;; corresponding entry is still on the standard undo list. @@ -203,11 +209,11 @@ Knows about CUA rectangle highlighting in addition to standard undo." (aref cua--rectangle 5)) (cua--rectangle-left)))) -(defun cua--rectangle-padding (&optional set val) - ;; Current setting of rectangle padding +(defun cua--rectangle-virtual-edges (&optional set val) + ;; Current setting of rectangle virtual-edges (if set (aset cua--rectangle 6 val)) - (and (not buffer-read-only) + (and ;(not buffer-read-only) (aref cua--rectangle 6))) (defun cua--rectangle-restriction (&optional val bounded negated) @@ -226,7 +232,7 @@ Knows about CUA rectangle highlighting in addition to standard undo." (if (< (cua--rectangle-bot) (cua--rectangle-top)) (message "rectangle bot < top"))) -(defun cua--rectangle-get-corners (&optional pad) +(defun cua--rectangle-get-corners () ;; Calculate the rectangular region represented by point and mark, ;; putting start in the upper left corner and end in the ;; bottom right corner. @@ -245,12 +251,12 @@ Knows about CUA rectangle highlighting in addition to standard undo." (setq r (1- r))) (setq l (prog1 r (setq r l))) (goto-char top) - (move-to-column l pad) + (move-to-column l) (setq top (point)) (goto-char bot) - (move-to-column r pad) + (move-to-column r) (setq bot (point)))) - (vector top bot l r corner 0 pad nil))) + (vector top bot l r corner 0 cua-virtual-rectangle-edges nil))) (defun cua--rectangle-set-corners () ;; Set mark and point in opposite corners of current rectangle. @@ -269,24 +275,31 @@ Knows about CUA rectangle highlighting in addition to standard undo." (setq pp (cua--rectangle-bot) pc (cua--rectangle-right) mp (cua--rectangle-top) mc (cua--rectangle-left)))) (goto-char mp) - (move-to-column mc (cua--rectangle-padding)) + (move-to-column mc) (set-mark (point)) (goto-char pp) - (move-to-column pc (cua--rectangle-padding)))) + ;; Move cursor inside rectangle, except if char at rigth edge is a tab. + (if (and (if (cua--rectangle-right-side) + (and (= (move-to-column pc) (- pc tab-width)) + (not (eolp))) + (> (move-to-column pc) pc)) + (not (bolp))) + (backward-char 1)) + )) ;;; Rectangle resizing -(defun cua--forward-line (n pad) +(defun cua--forward-line (n) ;; Move forward/backward one line. Returns t if movement. - (if (or (not pad) (< n 0)) - (= (forward-line n) 0) - (next-line 1) - t)) + (let ((pt (point))) + (and (= (forward-line n) 0) + ;; Deal with end of buffer + (or (not (eobp)) + (goto-char pt))))) (defun cua--rectangle-resized () ;; Refresh state after resizing rectangle (setq cua--buffer-and-point-before-command nil) - (cua--pad-rectangle) (cua--rectangle-insert-col 0) (cua--rectangle-set-corners) (cua--keep-active)) @@ -294,47 +307,35 @@ Knows about CUA rectangle highlighting in addition to standard undo." (defun cua-resize-rectangle-right (n) "Resize rectangle to the right." (interactive "p") - (let ((pad (cua--rectangle-padding)) (resized (> n 0))) + (let ((resized (> n 0))) (while (> n 0) (setq n (1- n)) (cond - ((and (cua--rectangle-right-side) (or pad (eolp))) - (cua--rectangle-right (1+ (cua--rectangle-right))) - (move-to-column (cua--rectangle-right) pad)) ((cua--rectangle-right-side) - (forward-char 1) - (cua--rectangle-right (current-column))) - ((or pad (eolp)) - (cua--rectangle-left (1+ (cua--rectangle-left))) - (move-to-column (cua--rectangle-right) pad)) + (cua--rectangle-right (1+ (cua--rectangle-right))) + (move-to-column (cua--rectangle-right))) (t - (forward-char 1) - (cua--rectangle-left (current-column))))) + (cua--rectangle-left (1+ (cua--rectangle-left))) + (move-to-column (cua--rectangle-right))))) (if resized (cua--rectangle-resized)))) (defun cua-resize-rectangle-left (n) "Resize rectangle to the left." (interactive "p") - (let ((pad (cua--rectangle-padding)) resized) + (let (resized) (while (> n 0) (setq n (1- n)) (if (or (= (cua--rectangle-right) 0) (and (not (cua--rectangle-right-side)) (= (cua--rectangle-left) 0))) (setq n 0) (cond - ((and (cua--rectangle-right-side) (or pad (eolp) (bolp))) - (cua--rectangle-right (1- (cua--rectangle-right))) - (move-to-column (cua--rectangle-right) pad)) ((cua--rectangle-right-side) - (backward-char 1) - (cua--rectangle-right (current-column))) - ((or pad (eolp) (bolp)) - (cua--rectangle-left (1- (cua--rectangle-left))) - (move-to-column (cua--rectangle-right) pad)) + (cua--rectangle-right (1- (cua--rectangle-right))) + (move-to-column (cua--rectangle-right))) (t - (backward-char 1) - (cua--rectangle-left (current-column)))) + (cua--rectangle-left (1- (cua--rectangle-left))) + (move-to-column (cua--rectangle-right)))) (setq resized t))) (if resized (cua--rectangle-resized)))) @@ -342,20 +343,20 @@ Knows about CUA rectangle highlighting in addition to standard undo." (defun cua-resize-rectangle-down (n) "Resize rectangle downwards." (interactive "p") - (let ((pad (cua--rectangle-padding)) resized) + (let (resized) (while (> n 0) (setq n (1- n)) (cond ((>= (cua--rectangle-corner) 2) (goto-char (cua--rectangle-bot)) - (when (cua--forward-line 1 pad) - (move-to-column (cua--rectangle-column) pad) + (when (cua--forward-line 1) + (move-to-column (cua--rectangle-column)) (cua--rectangle-bot t) (setq resized t))) (t (goto-char (cua--rectangle-top)) - (when (cua--forward-line 1 pad) - (move-to-column (cua--rectangle-column) pad) + (when (cua--forward-line 1) + (move-to-column (cua--rectangle-column)) (cua--rectangle-top t) (setq resized t))))) (if resized @@ -364,20 +365,20 @@ Knows about CUA rectangle highlighting in addition to standard undo." (defun cua-resize-rectangle-up (n) "Resize rectangle upwards." (interactive "p") - (let ((pad (cua--rectangle-padding)) resized) + (let (resized) (while (> n 0) (setq n (1- n)) (cond ((>= (cua--rectangle-corner) 2) (goto-char (cua--rectangle-bot)) - (when (cua--forward-line -1 pad) - (move-to-column (cua--rectangle-column) pad) + (when (cua--forward-line -1) + (move-to-column (cua--rectangle-column)) (cua--rectangle-bot t) (setq resized t))) (t (goto-char (cua--rectangle-top)) - (when (cua--forward-line -1 pad) - (move-to-column (cua--rectangle-column) pad) + (when (cua--forward-line -1) + (move-to-column (cua--rectangle-column)) (cua--rectangle-top t) (setq resized t))))) (if resized @@ -408,7 +409,7 @@ Knows about CUA rectangle highlighting in addition to standard undo." "Resize rectangle to bottom of buffer." (interactive) (goto-char (point-max)) - (move-to-column (cua--rectangle-column) (cua--rectangle-padding)) + (move-to-column (cua--rectangle-column)) (cua--rectangle-bot t) (cua--rectangle-resized)) @@ -416,31 +417,29 @@ Knows about CUA rectangle highlighting in addition to standard undo." "Resize rectangle to top of buffer." (interactive) (goto-char (point-min)) - (move-to-column (cua--rectangle-column) (cua--rectangle-padding)) + (move-to-column (cua--rectangle-column)) (cua--rectangle-top t) (cua--rectangle-resized)) (defun cua-resize-rectangle-page-up () "Resize rectangle upwards by one scroll page." (interactive) - (let ((pad (cua--rectangle-padding))) - (scroll-down) - (move-to-column (cua--rectangle-column) pad) - (if (>= (cua--rectangle-corner) 2) - (cua--rectangle-bot t) - (cua--rectangle-top t)) - (cua--rectangle-resized))) + (scroll-down) + (move-to-column (cua--rectangle-column)) + (if (>= (cua--rectangle-corner) 2) + (cua--rectangle-bot t) + (cua--rectangle-top t)) + (cua--rectangle-resized)) (defun cua-resize-rectangle-page-down () "Resize rectangle downwards by one scroll page." (interactive) - (let ((pad (cua--rectangle-padding))) - (scroll-up) - (move-to-column (cua--rectangle-column) pad) - (if (>= (cua--rectangle-corner) 2) - (cua--rectangle-bot t) - (cua--rectangle-top t)) - (cua--rectangle-resized))) + (scroll-up) + (move-to-column (cua--rectangle-column)) + (if (>= (cua--rectangle-corner) 2) + (cua--rectangle-bot t) + (cua--rectangle-top t)) + (cua--rectangle-resized)) ;;; Mouse support @@ -450,7 +449,8 @@ Knows about CUA rectangle highlighting in addition to standard undo." "Set rectangle corner at mouse click position." (interactive "e") (mouse-set-point event) - (if (cua--rectangle-padding) + ;; FIX ME -- need to calculate virtual column. + (if (cua--rectangle-virtual-edges) (move-to-column (car (posn-col-row (event-end event))) t)) (if (cua--rectangle-right-side) (cua--rectangle-right (current-column)) @@ -470,6 +470,7 @@ Knows about CUA rectangle highlighting in addition to standard undo." (cua--deactivate t)) (setq cua--last-rectangle nil) (mouse-set-point event) + ;; FIX ME -- need to calculate virtual column. (cua-set-rectangle-mark) (setq cua--buffer-and-point-before-command nil) (setq cua--mouse-last-pos nil)) @@ -489,13 +490,13 @@ If command is repeated at same position, delete the rectangle." (let ((cua-keep-region-after-copy t)) (cua-copy-rectangle arg) (setq cua--mouse-last-pos (cons (point) cua--last-killed-rectangle))))) + (defun cua--mouse-ignore (event) (interactive "e") (setq this-command last-command)) (defun cua--rectangle-move (dir) - (let ((pad (cua--rectangle-padding)) - (moved t) + (let ((moved t) (top (cua--rectangle-top)) (bot (cua--rectangle-bot)) (l (cua--rectangle-left)) @@ -503,17 +504,17 @@ If command is repeated at same position, delete the rectangle." (cond ((eq dir 'up) (goto-char top) - (when (cua--forward-line -1 pad) + (when (cua--forward-line -1) (cua--rectangle-top t) (goto-char bot) (forward-line -1) (cua--rectangle-bot t))) ((eq dir 'down) (goto-char bot) - (when (cua--forward-line 1 pad) + (when (cua--forward-line 1) (cua--rectangle-bot t) (goto-char top) - (cua--forward-line 1 pad) + (cua--forward-line 1) (cua--rectangle-top t))) ((eq dir 'left) (when (> l 0) @@ -526,19 +527,37 @@ If command is repeated at same position, delete the rectangle." (setq moved nil))) (when moved (setq cua--buffer-and-point-before-command nil) - (cua--pad-rectangle) (cua--rectangle-set-corners) (cua--keep-active)))) ;;; Operations on current rectangle -(defun cua--rectangle-operation (keep-clear visible undo pad &optional fct post-fct) +(defun cua--tabify-start (start end) + ;; Return position where auto-tabify should start (or nil if not required). + (save-excursion + (save-restriction + (widen) + (and (not buffer-read-only) + cua-auto-tabify-rectangles + (if (or (not (integerp cua-auto-tabify-rectangles)) + (= (point-min) (point-max)) + (progn + (goto-char (max (point-min) + (- start cua-auto-tabify-rectangles))) + (search-forward "\t" (min (point-max) + (+ end cua-auto-tabify-rectangles)) t))) + start))))) + +(defun cua--rectangle-operation (keep-clear visible undo pad tabify &optional fct post-fct) ;; Call FCT for each line of region with 4 parameters: ;; Region start, end, left-col, right-col ;; Point is at start when FCT is called + ;; Call fct with (s,e) = whole lines if VISIBLE non-nil. + ;; Only call fct for visible lines if VISIBLE==t. ;; Set undo boundary if UNDO is non-nil. - ;; Rectangle is padded if PAD = t or numeric and (cua--rectangle-padding) + ;; Rectangle is padded if PAD = t or numeric and (cua--rectangle-virtual-edges) + ;; Perform auto-tabify after operation if TABIFY is non-nil. ;; Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear. (let* ((start (cua--rectangle-top)) (end (cua--rectangle-bot)) @@ -546,11 +565,12 @@ If command is repeated at same position, delete the rectangle." (r (1+ (cua--rectangle-right))) (m (make-marker)) (tabpad (and (integerp pad) (= pad 2))) - (sel (cua--rectangle-restriction))) + (sel (cua--rectangle-restriction)) + (tabify-start (and tabify (cua--tabify-start start end)))) (if undo (cua--rectangle-undo-boundary)) (if (integerp pad) - (setq pad (cua--rectangle-padding))) + (setq pad (cua--rectangle-virtual-edges))) (save-excursion (save-restriction (widen) @@ -558,11 +578,13 @@ If command is repeated at same position, delete the rectangle." (goto-char end) (and (bolp) (not (eolp)) (not (eobp)) (setq end (1+ end)))) - (when visible + (when (eq visible t) (setq start (max (window-start) start)) (setq end (min (window-end) end))) (goto-char end) (setq end (line-end-position)) + (if (and visible (bolp) (not (eobp))) + (setq end (1+ end))) (goto-char start) (setq start (line-beginning-position)) (narrow-to-region start end) @@ -575,7 +597,7 @@ If command is repeated at same position, delete the rectangle." (forward-char 1)) (set-marker m (point)) (move-to-column l pad) - (if (and fct (>= (current-column) l) (<= (current-column) r)) + (if (and fct (or visible (and (>= (current-column) l) (<= (current-column) r)))) (let ((v t) (p (point))) (when sel (if (car (cdr sel)) @@ -585,8 +607,7 @@ If command is repeated at same position, delete the rectangle." (if (car (cdr (cdr sel))) (setq v (null v)))) (if visible - (unless (eolp) - (funcall fct p m l r v)) + (funcall fct p m l r v) (if v (funcall fct p m l r))))) (set-marker m nil) @@ -594,7 +615,9 @@ If command is repeated at same position, delete the rectangle." (if (not visible) (cua--rectangle-bot t)) (if post-fct - (funcall post-fct l r)))) + (funcall post-fct l r)) + (when tabify-start + (tabify tabify-start (point))))) (cond ((eq keep-clear 'keep) (cua--keep-active)) @@ -607,48 +630,96 @@ If command is repeated at same position, delete the rectangle." (put 'cua--rectangle-operation 'lisp-indent-function 4) -(defun cua--pad-rectangle (&optional pad) - (if (or pad (cua--rectangle-padding)) - (cua--rectangle-operation nil nil t t))) - (defun cua--delete-rectangle () - (cua--rectangle-operation nil nil t 2 - '(lambda (s e l r) - (if (and (> e s) (<= e (point-max))) - (delete-region s e))))) + (let ((lines 0)) + (if (not (cua--rectangle-virtual-edges)) + (cua--rectangle-operation nil nil t 2 t + '(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) + (setq lines (1+ lines)) + (when (and (> e s) (<= e (point-max))) + (delete-region s e))))) + lines)) (defun cua--extract-rectangle () (let (rect) - (cua--rectangle-operation nil nil nil 1 - '(lambda (s e l r) - (setq rect (cons (buffer-substring-no-properties s e) rect)))) - (nreverse rect))) - -(defun cua--insert-rectangle (rect &optional below) + (if (not (cua--rectangle-virtual-edges)) + (cua--rectangle-operation nil nil nil nil nil ; do not tabify + '(lambda (s e l r) + (setq rect (cons (buffer-substring-no-properties s e) rect)))) + (cua--rectangle-operation nil 1 nil nil nil ; do not tabify + '(lambda (s e l r v) + (let ((copy t) (bs 0) (as 0) row) + (if (= s e) (setq e (1+ e))) + (goto-char s) + (move-to-column l) + (if (= (point) (line-end-position)) + (setq bs (- r l) + copy nil) + (skip-chars-forward "\s\t" e) + (setq bs (- (min r (current-column)) l) + s (point)) + (move-to-column r) + (skip-chars-backward "\s\t" s) + (setq as (- r (max (current-column) l)) + e (point))) + (setq row (if (and copy (> e s)) + (buffer-substring-no-properties s e) + "")) + (when (> bs 0) + (setq row (concat (make-string bs ?\s) row))) + (when (> as 0) + (setq row (concat row (make-string as ?\s)))) + (setq rect (cons row rect)))))) + (nreverse rect))) + +(defun cua--insert-rectangle (rect &optional below paste-column line-count) ;; Insert rectangle as insert-rectangle, but don't set mark and exit with ;; point at either next to top right or below bottom left corner ;; Notice: In overwrite mode, the rectangle is inserted as separate text lines. - (if (and below (eq below 'auto)) + (if (eq below 'auto) (setq below (and (bolp) (or (eolp) (eobp) (= (1+ (point)) (point-max)))))) + (unless paste-column + (setq paste-column (current-column))) (let ((lines rect) - (insertcolumn (current-column)) (first t) + (tabify-start (cua--tabify-start (point) (point))) + last-column p) (while (or lines below) (or first (if overwrite-mode (insert ?\n) (forward-line 1) - (or (bolp) (insert ?\n)) - (move-to-column insertcolumn t))) + (or (bolp) (insert ?\n)))) + (unless overwrite-mode + (move-to-column paste-column t)) (if (not lines) (setq below nil) (insert-for-yank (car lines)) + (unless last-column + (setq last-column (current-column))) (setq lines (cdr lines)) (and first (not below) (setq p (point)))) - (setq first nil)) + (setq first nil) + (if (and line-count (= (setq line-count (1- line-count)) 0)) + (setq lines nil))) + (when (and line-count last-column (not overwrite-mode)) + (while (> line-count 0) + (forward-line 1) + (or (bolp) (insert ?\n)) + (move-to-column paste-column t) + (insert-char ?\s (- last-column paste-column -1)) + (setq line-count (1- line-count)))) + (when (and tabify-start + (not overwrite-mode)) + (tabify tabify-start (point))) (and p (not overwrite-mode) (goto-char p)))) @@ -662,7 +733,7 @@ If command is repeated at same position, delete the rectangle." (function (lambda (row) (concat row "\n"))) killed-rectangle ""))))) -(defun cua--activate-rectangle (&optional force) +(defun cua--activate-rectangle () ;; Turn on rectangular marking mode by disabling transient mark mode ;; and manually handling highlighting from a post command hook. ;; Be careful if we are already marking a rectangle. @@ -671,12 +742,8 @@ If command is repeated at same position, delete the rectangle." (eq (car cua--last-rectangle) (current-buffer)) (eq (car (cdr cua--last-rectangle)) (point))) (cdr (cdr cua--last-rectangle)) - (cua--rectangle-get-corners - (and (not buffer-read-only) - (or cua-auto-expand-rectangles - force - (eq major-mode 'picture-mode))))) - cua--status-string (if (cua--rectangle-padding) " Pad" "") + (cua--rectangle-get-corners)) + cua--status-string (if (cua--rectangle-virtual-edges) " [R]" "") cua--last-rectangle nil)) ;; (defvar cua-save-point nil) @@ -698,7 +765,7 @@ If command is repeated at same position, delete the rectangle." ;; Each overlay extends across all the columns of the rectangle. ;; We try to reuse overlays where possible because this is more efficient ;; and results in less flicker. - ;; If cua--rectangle-padding is nil and the buffer contains tabs or short lines, + ;; If cua--rectangle-virtual-edges is nil and the buffer contains tabs or short lines, ;; the higlighted region may not be perfectly rectangular. (let ((deactivate-mark deactivate-mark) (old cua--rectangle-overlays) @@ -707,12 +774,67 @@ If command is repeated at same position, delete the rectangle." (right (1+ (cua--rectangle-right)))) (when (/= left right) (sit-for 0) ; make window top/bottom reliable - (cua--rectangle-operation nil t nil nil + (cua--rectangle-operation nil t nil nil nil ; do not tabify '(lambda (s e l r v) (let ((rface (if v 'cua-rectangle-face 'cua-rectangle-noselect-face)) - overlay) - ;; Trim old leading overlays. + overlay bs ms as) (if (= s e) (setq e (1+ e))) + (when (cua--rectangle-virtual-edges) + (let ((lb (line-beginning-position)) + (le (line-end-position)) + cl cl0 pl cr cr0 pr) + (goto-char s) + (setq cl (move-to-column l) + pl (point)) + (setq cr (move-to-column r) + pr (point)) + (if (= lb pl) + (setq cl0 0) + (goto-char (1- pl)) + (setq cl0 (current-column))) + (if (= lb le) + (setq cr0 0) + (goto-char (1- pr)) + (setq cr0 (current-column))) + (unless (and (= cl l) (= cr r)) + (when (/= cl l) + (setq bs (propertize + (make-string + (- l cl0 (if (and (= le pl) (/= le lb)) 1 0)) + (if cua--virtual-edges-debug ?. ?\s)) + 'face 'default)) + (if (/= pl le) + (setq s (1- s)))) + (cond + ((= cr r) + (if (and (/= pr le) + (/= cr0 (1- cr)) + (or bs (/= cr0 (- cr tab-width))) + (/= (mod cr tab-width) 0)) + (setq e (1- e)))) + ((= cr cl) + (setq ms (propertize + (make-string + (- r l) + (if cua--virtual-edges-debug ?, ?\s)) + 'face rface)) + (if (cua--rectangle-right-side) + (put-text-property (1- (length ms)) (length ms) 'cursor t ms) + (put-text-property 0 1 'cursor t ms)) + (setq bs (concat bs ms)) + (setq rface nil)) + (t + (setq as (propertize + (make-string + (- r cr0 (if (= le pr) 1 0)) + (if cua--virtual-edges-debug ?~ ?\s)) + 'face rface)) + (if (cua--rectangle-right-side) + (put-text-property (1- (length as)) (length as) 'cursor t as) + (put-text-property 0 1 'cursor t as)) + (if (/= pr le) + (setq e (1- e)))))))) + ;; Trim old leading overlays. (while (and old (setq overlay (car old)) (< (overlay-start overlay) s) @@ -728,8 +850,11 @@ If command is repeated at same position, delete the rectangle." (move-overlay overlay s e) (setq old (cdr old))) (setq overlay (make-overlay s e))) - (overlay-put overlay 'face rface) - (setq new (cons overlay new)))))) + (overlay-put overlay 'before-string bs) + (overlay-put overlay 'after-string as) + (overlay-put overlay 'face rface) + (overlay-put overlay 'keymap cua--overlay-keymap) + (setq new (cons overlay new)))))) ;; Trim old trailing overlays. (mapcar (function delete-overlay) old) (setq cua--rectangle-overlays (nreverse new)))) @@ -737,9 +862,9 @@ If command is repeated at same position, delete the rectangle." (defun cua--indent-rectangle (&optional ch to-col clear) ;; Indent current rectangle. (let ((col (cua--rectangle-insert-col)) - (pad (cua--rectangle-padding)) + (pad (cua--rectangle-virtual-edges)) indent) - (cua--rectangle-operation (if clear 'clear 'corners) nil t pad + (cua--rectangle-operation (if clear 'clear 'corners) nil t pad nil '(lambda (s e l r) (move-to-column col pad) (if (and (eolp) @@ -875,23 +1000,22 @@ With prefix argument, the toggle restriction." (defun cua-rotate-rectangle () (interactive) (cua--rectangle-corner (if (= (cua--rectangle-left) (cua--rectangle-right)) 0 1)) - (cua--rectangle-set-corners)) + (cua--rectangle-set-corners) + (if (cua--rectangle-virtual-edges) + (setq cua--buffer-and-point-before-command nil))) -(defun cua-toggle-rectangle-padding () +(defun cua-toggle-rectangle-virtual-edges () (interactive) - (if buffer-read-only - (message "Cannot do padding in read-only buffer.") - (cua--rectangle-padding t (not (cua--rectangle-padding))) - (cua--pad-rectangle) - (cua--rectangle-set-corners)) - (setq cua--status-string (and (cua--rectangle-padding) " Pad")) + (cua--rectangle-virtual-edges t (not (cua--rectangle-virtual-edges))) + (cua--rectangle-set-corners) + (setq cua--status-string (and (cua--rectangle-virtual-edges) " [R]")) (cua--keep-active)) (defun cua-do-rectangle-padding () (interactive) (if buffer-read-only (message "Cannot do padding in read-only buffer.") - (cua--pad-rectangle t) + (cua--rectangle-operation nil nil t t t) (cua--rectangle-set-corners)) (cua--keep-active)) @@ -900,7 +1024,7 @@ With prefix argument, the toggle restriction." 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 + (cua--rectangle-operation 'corners nil t 1 nil '(lambda (s e l r) (skip-chars-forward " \t") (let ((ws (- (current-column) l)) @@ -915,7 +1039,7 @@ On each line in the rectangle, all continuous whitespace starting 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 + (cua--rectangle-operation 'clear nil t 1 nil '(lambda (s e l r) (when arg (skip-syntax-backward " " (line-beginning-position)) @@ -927,7 +1051,7 @@ With prefix arg, also delete whitespace to the left of that column." "Blank out CUA rectangle. The text previously in the rectangle is overwritten by the blanks." (interactive) - (cua--rectangle-operation 'keep nil nil 1 + (cua--rectangle-operation 'keep nil nil 1 nil '(lambda (s e l r) (goto-char e) (skip-syntax-forward " " (line-end-position)) @@ -942,7 +1066,7 @@ The text previously in the rectangle is overwritten by the blanks." "Align rectangle lines to left column." (interactive) (let (x) - (cua--rectangle-operation 'clear nil t t + (cua--rectangle-operation 'clear nil t t nil '(lambda (s e l r) (let ((b (line-beginning-position))) (skip-syntax-backward "^ " b) @@ -984,7 +1108,7 @@ The text previously in the rectangle is overwritten by the blanks." "Replace CUA rectangle contents with STRING on each line. The length of STRING need not be the same as the rectangle width." (interactive "sString rectangle: ") - (cua--rectangle-operation 'keep nil t t + (cua--rectangle-operation 'keep nil t t nil '(lambda (s e l r) (delete-region s e) (skip-chars-forward " \t") @@ -999,7 +1123,7 @@ The length of STRING need not be the same as the rectangle width." (defun cua-fill-char-rectangle (ch) "Replace CUA rectangle contents with CHARACTER." (interactive "cFill rectangle with character: ") - (cua--rectangle-operation 'clear nil t 1 + (cua--rectangle-operation 'clear nil t 1 nil '(lambda (s e l r) (delete-region s e) (move-to-column l t) @@ -1010,7 +1134,7 @@ The length of STRING need not be the same as the rectangle width." (interactive "sReplace regexp: \nsNew text: ") (if buffer-read-only (message "Cannot replace in read-only buffer") - (cua--rectangle-operation 'keep nil t 1 + (cua--rectangle-operation 'keep nil t 1 nil '(lambda (s e l r) (if (re-search-forward regexp e t) (replace-match newtext nil nil)))))) @@ -1018,7 +1142,7 @@ The length of STRING need not be the same as the rectangle width." (defun cua-incr-rectangle (increment) "Increment each line of CUA rectangle by prefix amount." (interactive "p") - (cua--rectangle-operation 'keep nil t 1 + (cua--rectangle-operation 'keep nil t 1 nil '(lambda (s e l r) (cond ((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t) @@ -1051,36 +1175,36 @@ The numbers are formatted according to the FORMAT string." (if (= (length fmt) 0) (setq fmt cua--rectangle-seq-format) (setq cua--rectangle-seq-format fmt)) - (cua--rectangle-operation 'clear nil t 1 + (cua--rectangle-operation 'clear nil t 1 nil '(lambda (s e l r) (delete-region s e) (insert (format fmt first)) (setq first (+ first incr))))) -(defmacro cua--convert-rectangle-as (command) - `(cua--rectangle-operation 'clear nil nil nil +(defmacro cua--convert-rectangle-as (command tabify) + `(cua--rectangle-operation 'clear nil nil nil ,tabify '(lambda (s e l r) (,command s e)))) (defun cua-upcase-rectangle () "Convert the rectangle to upper case." (interactive) - (cua--convert-rectangle-as upcase-region)) + (cua--convert-rectangle-as upcase-region nil)) (defun cua-downcase-rectangle () "Convert the rectangle to lower case." (interactive) - (cua--convert-rectangle-as downcase-region)) + (cua--convert-rectangle-as downcase-region nil)) (defun cua-upcase-initials-rectangle () "Convert the rectangle initials to upper case." (interactive) - (cua--convert-rectangle-as upcase-initials-region)) + (cua--convert-rectangle-as upcase-initials-region nil)) (defun cua-capitalize-rectangle () "Convert the rectangle to proper case." (interactive) - (cua--convert-rectangle-as capitalize-region)) + (cua--convert-rectangle-as capitalize-region nil)) ;;; Replace/rearrange text in current rectangle @@ -1116,7 +1240,7 @@ The numbers are formatted according to the FORMAT string." (setq z (reverse z)) (if cua--debug (print z auxbuf)) - (cua--rectangle-operation nil nil t pad + (cua--rectangle-operation nil nil t pad nil '(lambda (s e l r) (let (cc) (goto-char e) @@ -1232,9 +1356,9 @@ With prefix arg, indent to that column." "Delete char to left or right of rectangle." (interactive) (let ((col (cua--rectangle-insert-col)) - (pad (cua--rectangle-padding)) + (pad (cua--rectangle-virtual-edges)) indent) - (cua--rectangle-operation 'corners nil t pad + (cua--rectangle-operation 'corners nil t pad nil '(lambda (s e l r) (move-to-column (if (cua--rectangle-right-side t) @@ -1282,10 +1406,7 @@ With prefix arg, indent to that column." (cua--rectangle-left (current-column))) (if (>= (cua--rectangle-corner) 2) (cua--rectangle-bot t) - (cua--rectangle-top t)) - (if (cua--rectangle-padding) - (setq unread-command-events - (cons (if cua-use-hyper-key ?\H-P ?\M-P) unread-command-events))))) + (cua--rectangle-top t)))) (if cua--rectangle (if (and mark-active (not deactivate-mark)) @@ -1379,7 +1500,7 @@ With prefix arg, indent to that column." (cua--rect-M/H-key ?m 'cua-copy-rectangle-as-text) (cua--rect-M/H-key ?n 'cua-sequence-rectangle) (cua--rect-M/H-key ?o 'cua-open-rectangle) - (cua--rect-M/H-key ?p 'cua-toggle-rectangle-padding) + (cua--rect-M/H-key ?p 'cua-toggle-rectangle-virtual-edges) (cua--rect-M/H-key ?P 'cua-do-rectangle-padding) (cua--rect-M/H-key ?q 'cua-refill-rectangle) (cua--rect-M/H-key ?r 'cua-replace-in-rectangle) |