;;; cua-rect.el --- CUA unified rectangle support
-;; Copyright (C) 1997-2002 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006 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; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Acknowledgements
(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)
;; List of overlays used to display current rectangle.
(defvar cua--rectangle-overlays nil)
(make-variable-buffer-local 'cua--rectangle-overlays)
+(put 'cua--rectangle-overlays 'permanent-local t)
-;; Per-buffer CUA mode undo list.
-(defvar cua--undo-list nil)
-(make-variable-buffer-local 'cua--undo-list)
+(defvar cua--overlay-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\r" 'cua-rotate-rectangle)))
+
+(defvar cua--virtual-edges-debug nil)
+
+;; Undo rectangle commands.
+
+(defvar cua--rect-undo-set-point nil)
-;; Record undo boundary for rectangle undo.
(defun cua--rectangle-undo-boundary ()
(when (listp buffer-undo-list)
- (if (> (length cua--undo-list) cua-undo-max)
- (setcdr (nthcdr (1- cua-undo-max) cua--undo-list) nil))
- (undo-boundary)
- (setq cua--undo-list
- (cons (cons (cdr buffer-undo-list) (copy-sequence cua--rectangle)) cua--undo-list))))
-
-(defun cua--rectangle-undo (&optional arg)
- "Undo some previous changes.
-Knows about CUA rectangle highlighting in addition to standard undo."
- (interactive "*P")
- (if cua--rectangle
- (cua--rectangle-undo-boundary))
- (undo arg)
- (let ((l cua--undo-list))
- (while l
- (if (eq (car (car l)) pending-undo-list)
- (setq cua--restored-rectangle
- (and (vectorp (cdr (car l))) (cdr (car l)))
- l nil)
- (setq l (cdr l)))))
- (setq cua--buffer-and-point-before-command nil))
-
-(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.
-;; 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.
-
-(defun cua--tidy-undo-lists (&optional clean)
- (let ((buffers (buffer-list)) (cnt cua--tidy-undo-counter))
- (while (and buffers (or clean (not (input-pending-p))))
- (with-current-buffer (car buffers)
- (when (local-variable-p 'cua--undo-list)
- (if (or clean (null cua--undo-list) (eq buffer-undo-list t))
- (progn
- (kill-local-variable 'cua--undo-list)
- (setq cua--tidy-undo-counter (1+ cua--tidy-undo-counter)))
- (let* ((bul buffer-undo-list)
- (cul (cons nil cua--undo-list))
- (cc (car (car (cdr cul)))))
- (while (and bul cc)
- (if (setq bul (memq cc bul))
- (setq cul (cdr cul)
- cc (and (cdr cul) (car (car (cdr cul)))))))
- (when cc
- (if cua--debug
- (setq cc (length (cdr cul))))
- (if (eq (cdr cul) cua--undo-list)
- (setq cua--undo-list nil)
- (setcdr cul nil))
- (setq cua--tidy-undo-counter (1+ cua--tidy-undo-counter))
- (if cua--debug
- (message "Clean undo list in %s (%d)"
- (buffer-name) cc)))))))
- (setq buffers (cdr buffers)))
- (/= cnt cua--tidy-undo-counter)))
+ (let ((s (cua--rect-start-position))
+ (e (cua--rect-end-position)))
+ (undo-boundary)
+ (push (list 'apply 0 s e
+ 'cua--rect-undo-handler
+ (copy-sequence cua--rectangle) t s e)
+ buffer-undo-list))))
+
+(defun cua--rect-undo-handler (rect on s e)
+ (if (setq on (not on))
+ (setq cua--rect-undo-set-point s)
+ (setq cua--restored-rectangle (copy-sequence rect))
+ (setq cua--buffer-and-point-before-command nil))
+ (push (list 'apply 0 s (if on e s)
+ 'cua--rect-undo-handler rect on s e)
+ buffer-undo-list))
;;; Rectangle geometry
(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)
(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.
(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.
(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))
+ ))
+
+(defun cua--rect-start-position ()
+ ;; Return point of top left corner
+ (save-excursion
+ (goto-char (cua--rectangle-top))
+ (and (> (move-to-column (cua--rectangle-left))
+ (cua--rectangle-left))
+ (not (bolp))
+ (backward-char 1))
+ (point)))
+
+(defun cua--rect-end-position ()
+ ;; Return point of bottom right cornet
+ (save-excursion
+ (goto-char (cua--rectangle-bot))
+ (and (= (move-to-column (cua--rectangle-right))
+ (- (cua--rectangle-right) tab-width))
+ (not (eolp))
+ (not (bolp))
+ (backward-char 1))
+ (point)))
;;; 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))
(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))))
(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
(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
"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))
"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
"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))
(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))
(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))
(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)
(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))
+ (let* ((inhibit-field-text-motion t)
+ (start (cua--rectangle-top))
(end (cua--rectangle-bot))
(l (cua--rectangle-left))
(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)
(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)
(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))
(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)
(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))
(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))))
(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.
(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)
;; 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)
(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.
- (if (= s e) (setq e (1+ e)))
+ (let ((rface (if v 'cua-rectangle 'cua-rectangle-noselect))
+ overlay bs ms as)
+ (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 (or (get-text-property (1- 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)
(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)
+ (overlay-put overlay 'window (selected-window))
+ (setq new (cons overlay new))))))
;; Trim old trailing overlays.
(mapcar (function delete-overlay) old)
(setq cua--rectangle-overlays (nreverse new))))
(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)
(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)
+ (message "Cannot do padding in read-only buffer")
+ (cua--rectangle-operation nil nil t t t)
(cua--rectangle-set-corners))
(cua--keep-active))
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))
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))
"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))
"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)
"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")
'(lambda (l r)
(cua--rectangle-right (max l (+ l (length string) -1)))))))
-(defun cua-fill-char-rectangle (ch)
+(defun cua-fill-char-rectangle (character)
"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)
- (insert-char ch (- r l)))))
+ (insert-char character (- r l)))))
(defun cua-replace-in-rectangle (regexp newtext)
"Replace REGEXP with NEWTEXT in each line of CUA rectangle."
(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))))))
(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)
(t nil)))))
(defvar cua--rectangle-seq-format "%d"
- "Last format used by cua-sequence-rectangle.")
+ "Last format used by `cua-sequence-rectangle'.")
-(defun cua-sequence-rectangle (first incr fmt)
+(defun cua-sequence-rectangle (first incr format)
"Resequence each line of CUA rectangle starting from FIRST.
The numbers are formatted according to the FORMAT string."
(interactive
(string-to-number
(read-string "Increment: (1) " nil nil "1"))
(read-string (concat "Format: (" cua--rectangle-seq-format ") "))))
- (if (= (length fmt) 0)
- (setq fmt cua--rectangle-seq-format)
- (setq cua--rectangle-seq-format fmt))
- (cua--rectangle-operation 'clear nil t 1
+ (if (= (length format) 0)
+ (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)
(delete-region s e)
- (insert (format fmt first))
+ (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)
+ (,command s e))))
+
(defun cua-upcase-rectangle ()
"Convert the rectangle to upper case."
(interactive)
- (cua--rectangle-operation 'clear nil nil nil
- '(lambda (s e l r)
- (upcase-region s e))))
+ (cua--convert-rectangle-as upcase-region nil))
(defun cua-downcase-rectangle ()
"Convert the rectangle to lower case."
(interactive)
- (cua--rectangle-operation 'clear nil nil nil
- '(lambda (s e l r)
- (downcase-region s e))))
+ (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 nil))
+
+(defun cua-capitalize-rectangle ()
+ "Convert the rectangle to proper case."
+ (interactive)
+ (cua--convert-rectangle-as capitalize-region nil))
;;; Replace/rearrange text in current rectangle
(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)
(setq z (cdr z)))
(if cua--debug
(print (list (current-column) cc) auxbuf))
+ (just-one-space 0)
(indent-to cc))))
(if (> tr 0)
(message "Warning: Truncated %d row%s" tr (if (> tr 1) "s" "")))
"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)
(defun cua-help-for-rectangle (&optional help)
(interactive)
- (let ((M (if cua-use-hyper-key " H-" " M-")))
+ (let ((M (cond ((eq cua--rectangle-modifier-key 'hyper) " H-")
+ ((eq cua--rectangle-modifier-key 'super) " s-")
+ (t " M-"))))
(message
(concat (if help "C-?:help" "")
M "p:pad" M "o:open" M "c:close" M "b:blank"
(defun cua--rectangle-post-command ()
(if cua--restored-rectangle
- (setq cua--rectangle cua--restored-rectangle
- cua--restored-rectangle nil
- mark-active t
- deactivate-mark nil)
+ (progn
+ (setq cua--rectangle cua--restored-rectangle
+ cua--restored-rectangle nil
+ mark-active t
+ deactivate-mark nil)
+ (cua--rectangle-set-corners))
(when (and cua--rectangle cua--buffer-and-point-before-command
(equal (car cua--buffer-and-point-before-command) (current-buffer))
(not (= (cdr cua--buffer-and-point-before-command) (point))))
(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))
(cua--highlight-rectangle)
- (cua--deactivate-rectangle))))
-
+ (cua--deactivate-rectangle))
+ (when cua--rectangle-overlays
+ ;; clean-up after revert-buffer
+ (mapcar (function delete-overlay) cua--rectangle-overlays)
+ (setq cua--rectangle-overlays nil)
+ (setq deactivate-mark t)))
+ (when cua--rect-undo-set-point
+ (goto-char cua--rect-undo-set-point)
+ (setq cua--rect-undo-set-point nil)))
;;; Initialization
(defun cua--rect-M/H-key (key cmd)
(cua--M/H-key cua--rectangle-keymap key cmd))
-(defun cua--rectangle-on-off (on)
- (cancel-function-timers 'cua--tidy-undo-lists)
- (if on
- (run-with-idle-timer 10 t 'cua--tidy-undo-lists)
- (cua--tidy-undo-lists t)))
-
(defun cua--init-rectangles ()
- (unless (face-background 'cua-rectangle-face)
- (copy-face 'region 'cua-rectangle-face)
- (set-face-background 'cua-rectangle-face "maroon")
- (set-face-foreground 'cua-rectangle-face "white"))
-
- (unless (face-background 'cua-rectangle-noselect-face)
- (copy-face 'region 'cua-rectangle-noselect-face)
- (set-face-background 'cua-rectangle-noselect-face "dimgray")
- (set-face-foreground 'cua-rectangle-noselect-face "white"))
-
- (unless (eq cua-use-hyper-key 'only)
- (define-key cua--rectangle-keymap [(shift return)] 'cua-clear-rectangle-mark)
- (define-key cua--region-keymap [(shift return)] 'cua-toggle-rectangle-mark))
- (when cua-use-hyper-key
- (cua--rect-M/H-key 'space 'cua-clear-rectangle-mark)
- (cua--M/H-key cua--region-keymap 'space 'cua-toggle-rectangle-mark))
+ (define-key cua--rectangle-keymap [(control return)] 'cua-clear-rectangle-mark)
+ (define-key cua--region-keymap [(control return)] 'cua-toggle-rectangle-mark)
+ (unless (eq cua--rectangle-modifier-key 'meta)
+ (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)
(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)