root/trunk/lisp/emulation/cua-rect.el

;;; cua-rect.el --- CUA unified rectangle support

;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience CUA

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Acknowledgements

;; The rectangle handling and display code borrows from the standard
;; GNU emacs rect.el package and the rect-mark.el package by Rick
;; Sladkey <jrs@world.std.com>.

;;; Commentary:

;;; Code:

(provide 'cua-rect)

(eval-when-compile
  (require 'cua-base)
  (require 'cua-gmrk)
)

;;; Rectangle support

(require 'rect)

;; If non-nil, restrict current region to this rectangle.
;; 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 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)

;; Most recent rectangle geometry.  Note: car is buffer.
(defvar cua--last-rectangle nil)

;; Rectangle restored by undo.
(defvar cua--restored-rectangle nil)

;; Last rectangle copied/killed; nil if last kill was not a rectangle.
(defvar cua--last-killed-rectangle nil)

;; 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)

(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)

(defun cua--rectangle-undo-boundary ()
  (when (listp buffer-undo-list)
    (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

(defun cua--rectangle-top (&optional val)
  ;; Top of CUA rectangle (buffer position on first line).
  (if (not val)
      (aref cua--rectangle 0)
    (setq val (line-beginning-position))
    (if (<= val (aref cua--rectangle 1))
        (aset cua--rectangle 0 val)
      (aset cua--rectangle 1 val)
      (cua--rectangle-corner 2))))

(defun cua--rectangle-bot (&optional val)
  ;; Bot of CUA rectangle (buffer position on last line).
  (if (not val)
      (aref cua--rectangle 1)
    (setq val (line-end-position))
    (if (>= val (aref cua--rectangle 0))
        (aset cua--rectangle 1 val)
      (aset cua--rectangle 0 val)
      (cua--rectangle-corner 2))))

(defun cua--rectangle-left (&optional val)
  ;; Left column of CUA rectangle.
  (if (integerp val)
      (if (<= val (aref cua--rectangle 3))
          (aset cua--rectangle 2 val)
        (aset cua--rectangle 3 val)
        (cua--rectangle-corner (if (cua--rectangle-right-side) -1 1)))
    (aref cua--rectangle 2)))

(defun cua--rectangle-right (&optional val)
  ;; Right column of CUA rectangle.
  (if (integerp val)
      (if (>= val (aref cua--rectangle 2))
          (aset cua--rectangle 3 val)
        (aset cua--rectangle 2 val)
        (cua--rectangle-corner (if (cua--rectangle-right-side) -1 1)))
    (aref cua--rectangle 3)))

(defun cua--rectangle-corner (&optional advance)
  ;; Currently active corner of rectangle.
  (let ((c (aref cua--rectangle 4)))
    (if (not (integerp advance))
        c
      (aset cua--rectangle 4
            (if (= advance 0)
                (- 3 c) ; opposite corner
              (mod (+ c 4 advance) 4)))
      (aset cua--rectangle 5 0))))

(defun cua--rectangle-right-side (&optional topbot)
  ;; t if point is on right side of rectangle.
  (if (and topbot (= (cua--rectangle-left) (cua--rectangle-right)))
      (< (cua--rectangle-corner) 2)
    (= (mod (cua--rectangle-corner) 2) 1)))

(defun cua--rectangle-column ()
  (if (cua--rectangle-right-side)
      (cua--rectangle-right)
    (cua--rectangle-left)))

(defun cua--rectangle-insert-col (&optional col)
  ;; Currently active corner of rectangle.
  (if (integerp col)
      (aset cua--rectangle 5 col)
    (if (cua--rectangle-right-side t)
        (if (= (aref cua--rectangle 5) 0)
            (1+ (cua--rectangle-right))
          (aref cua--rectangle 5))
      (cua--rectangle-left))))

(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)
       (aref cua--rectangle 6)))

(defun cua--rectangle-restriction (&optional val bounded negated)
  ;; Current rectangle restriction
  (if val
      (aset cua--rectangle 7
            (and (stringp val)
             (> (length val) 0)
             (list val bounded negated)))
    (aref cua--rectangle 7)))

(defun cua--rectangle-assert ()
  (message "%S (%d)" cua--rectangle (point))
  (if (< (cua--rectangle-right) (cua--rectangle-left))
      (message "rectangle right < left"))
  (if (< (cua--rectangle-bot) (cua--rectangle-top))
      (message "rectangle bot < top")))

(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.
  (let ((top (point)) (bot (mark)) r l corner)
    (save-excursion
      (goto-char top)
      (setq l (current-column))
      (goto-char bot)
      (setq r (current-column))
      (if (<= top bot)
          (setq corner (if (<= l r) 0 1))
        (setq top (prog1 bot (setq bot top)))
        (setq corner (if (<= l r) 2 3)))
      (if (<= l r)
          (if (< l r)
              (setq r (1- r)))
        (setq l (prog1 r (setq r l)))
        (goto-char top)
        (move-to-column l)
        (setq top (point))
        (goto-char bot)
        (move-to-column r)
        (setq bot (point))))
    (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.
  (let (pp pc mp mc (c (cua--rectangle-corner)))
    (cond
     ((= c 0)  ; top/left -> bot/right
      (setq pp (cua--rectangle-top) pc (cua--rectangle-left)
            mp (cua--rectangle-bot) mc (cua--rectangle-right)))
     ((= c 1)  ; top/right -> bot/left
      (setq pp (cua--rectangle-top) pc (cua--rectangle-right)
            mp (cua--rectangle-bot) mc (cua--rectangle-left)))
     ((= c 2)  ; bot/left -> top/right
      (setq pp (cua--rectangle-bot) pc (cua--rectangle-left)
            mp (cua--rectangle-top) mc (cua--rectangle-right)))
     ((= c 3)  ; bot/right -> top/left
      (setq pp (cua--rectangle-bot) pc (cua--rectangle-right)
            mp (cua--rectangle-top) mc (cua--rectangle-left))))
    (goto-char mp)
    (move-to-column mc)
    (set-mark (point))
    (goto-char pp)
    ;; 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)
  ;; Move forward/backward one line.  Returns t if movement.
  (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--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 ((resized (> n 0)))
    (while (> n 0)
      (setq n (1- n))
      (cond
       ((cua--rectangle-right-side)
        (cua--rectangle-right (1+ (cua--rectangle-right)))
        (move-to-column (cua--rectangle-right)))
       (t
        (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 (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
         ((cua--rectangle-right-side)
          (cua--rectangle-right (1- (cua--rectangle-right)))
          (move-to-column (cua--rectangle-right)))
         (t
          (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 (resized)
    (while (> n 0)
      (setq n (1- n))
      (cond
       ((>= (cua--rectangle-corner) 2)
        (goto-char (cua--rectangle-bot))
        (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)
          (move-to-column (cua--rectangle-column))
          (cua--rectangle-top t)
          (setq resized t)))))
    (if resized
        (cua--rectangle-resized))))

(defun cua-resize-rectangle-up (n)
  "Resize rectangle upwards."
  (interactive "p")
  (let (resized)
    (while (> n 0)
      (setq n (1- n))
      (cond
       ((>= (cua--rectangle-corner) 2)
        (goto-char (cua--rectangle-bot))
        (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)
          (move-to-column (cua--rectangle-column))
          (cua--rectangle-top t)
          (setq resized t)))))
    (if resized
        (cua--rectangle-resized))))

(defun cua-resize-rectangle-eol ()
  "Resize rectangle to end of line."
  (interactive)
  (unless (eolp)
    (end-of-line)
    (if (> (current-column) (cua--rectangle-right))
        (cua--rectangle-right (current-column)))
    (if (not (cua--rectangle-right-side))
        (cua--rectangle-corner 1))
    (cua--rectangle-resized)))

(defun cua-resize-rectangle-bol ()
  "Resize rectangle to beginning of line."
  (interactive)
  (unless (bolp)
    (beginning-of-line)
    (cua--rectangle-left (current-column))
    (if (cua--rectangle-right-side)
        (cua--rectangle-corner -1))
    (cua--rectangle-resized)))

(defun cua-resize-rectangle-bot ()
  "Resize rectangle to bottom of buffer."
  (interactive)
  (goto-char (point-max))
  (move-to-column (cua--rectangle-column))
  (cua--rectangle-bot t)
  (cua--rectangle-resized))

(defun cua-resize-rectangle-top ()
  "Resize rectangle to top of buffer."
  (interactive)
  (goto-char (point-min))
  (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)
  (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)
  (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

;; This is pretty simplistic, but it does the job...

(defun cua-mouse-resize-rectangle (event)
  "Set rectangle corner at mouse click position."
  (interactive "e")
  (mouse-set-point event)
  ;; 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--rectangle-left (current-column)))
  (if (>= (cua--rectangle-corner) 2)
      (cua--rectangle-bot t)
    (cua--rectangle-top t))
  (cua--rectangle-resized))

(defvar cua--mouse-last-pos nil)

(defun cua-mouse-set-rectangle-mark (event)
  "Start rectangle at mouse click position."
  (interactive "e")
  (when cua--rectangle
    (cua--deactivate-rectangle)
    (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))

(defun cua-mouse-save-then-kill-rectangle (event arg)
  "Expand rectangle to mouse click position and copy rectangle.
If command is repeated at same position, delete the rectangle."
  (interactive "e\nP")
  (if (and (eq this-command last-command)
           (eq (point) (car-safe cua--mouse-last-pos))
           (eq cua--last-killed-rectangle (cdr-safe cua--mouse-last-pos)))
      (progn
        (unless buffer-read-only
          (cua--delete-rectangle))
        (cua--deactivate))
    (cua-mouse-resize-rectangle event)
    (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 ((moved t)
        (top (cua--rectangle-top))
        (bot (cua--rectangle-bot))
        (l (cua--rectangle-left))
        (r (cua--rectangle-right)))
    (cond
     ((eq dir 'up)
      (goto-char top)
      (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)
        (cua--rectangle-bot t)
        (goto-char top)
        (cua--forward-line 1)
        (cua--rectangle-top t)))
     ((eq dir 'left)
      (when (> l 0)
        (cua--rectangle-left (1- l))
        (cua--rectangle-right (1- r))))
     ((eq dir 'right)
      (cua--rectangle-right (1+ r))
      (cua--rectangle-left (1+ l)))
     (t
      (setq moved nil)))
    (when moved
      (setq cua--buffer-and-point-before-command nil)
      (cua--rectangle-set-corners)
      (cua--keep-active))))


;;; Operations on current rectangle

(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-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* ((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))
         (tabify-start (and tabify (cua--tabify-start start end))))
    (if undo
        (cua--rectangle-undo-boundary))
    (if (integerp pad)
        (setq pad (cua--rectangle-virtual-edges)))
    (save-excursion
      (save-restriction
        (widen)
        (when (> (cua--rectangle-corner) 1)
          (goto-char end)
          (and (bolp) (not (eolp)) (not (eobp))
               (setq end (1+ end))))
        (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)
        (goto-char (point-min))
        (while (< (point) (point-max))
          (move-to-column r pad)
          (and (not pad) (not visible) (> (current-column) r)
               (backward-char 1))
          (if (and tabpad (not pad) (looking-at "\t"))
              (forward-char 1))
          (set-marker m (point))
          (move-to-column l pad)
          (if (and fct (or visible (and (>= (current-column) l) (<= (current-column) r))))
              (let ((v t) (p (point)))
                (when sel
                  (if (car (cdr sel))
                      (setq v (looking-at (car sel)))
                    (setq v (re-search-forward (car sel) m t))
                    (goto-char p))
                  (if (car (cdr (cdr sel)))
                      (setq v (null v))))
                (if visible
                    (funcall fct p m l r v)
                  (if v
                      (funcall fct p m l r)))))
          (set-marker m nil)
          (forward-line 1))
        (if (not visible)
            (cua--rectangle-bot t))
        (if post-fct
            (funcall post-fct l r))
        (when tabify-start
          (tabify tabify-start (point)))))
    (cond
     ((eq keep-clear 'keep)
      (cua--keep-active))
     ((eq keep-clear 'clear)
      (cua--deactivate))
     ((eq keep-clear 'corners)
      (cua--rectangle-set-corners)
      (cua--keep-active)))
    (setq cua--buffer-and-point-before-command nil)))

(put 'cua--rectangle-operation 'lisp-indent-function 4)

(defun cua--delete-rectangle ()
  (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)
    (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 (filter-buffer-substring s e nil t) 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))
                           (filter-buffer-substring s e nil t)
                         ""))
             (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 (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)
        (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))))
      (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)
      (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))))

(defun cua--copy-rectangle-as-kill (&optional ring)
  (if cua--register
      (set-register cua--register (cua--extract-rectangle))
    (setq killed-rectangle (cua--extract-rectangle))
    (setq cua--last-killed-rectangle (cons (and kill-ring (car kill-ring)) killed-rectangle))
    (if ring
        (kill-new (mapconcat
                   (function (lambda (row) (concat row "\n")))
                   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.
  ;; Be careful if we are already marking a rectangle.
  (setq cua--rectangle
        (if (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))
        cua--status-string (if (cua--rectangle-virtual-edges) " [R]" "")
        cua--last-rectangle nil))

;; (defvar cua-save-point nil)

(defun cua--deactivate-rectangle ()
  ;; This is used to clean up after `cua--activate-rectangle'.
  (mapcar (function 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))

(defun cua--highlight-rectangle ()
  ;; This function is used to highlight the rectangular region.
  ;; We do this by putting an overlay on each line within 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-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)
        (new nil)
        (left (cua--rectangle-left))
        (right (1+ (cua--rectangle-right))))
    (when (/= left right)
      (sit-for 0)  ; make window top/bottom reliable
      (cua--rectangle-operation nil t nil nil nil ; do not tabify
        '(lambda (s e l r v)
           (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 2 ms)
                       (put-text-property 0 1 'cursor 2 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 2 as)
                       (put-text-property 0 1 'cursor 2 as))
                     (if (/= pr le)
                         (setq e (1- e))))))))
             ;; Trim old leading overlays.
             (while (and old
                         (setq overlay (car old))
                         (< (overlay-start overlay) s)
                         (/= (overlay-end overlay) e))
               (delete-overlay overlay)
               (setq old (cdr old)))
             ;; Reuse an overlay if possible, otherwise create one.
             (if (and old
                      (setq overlay (car old))
                      (or (= (overlay-start overlay) s)
                          (= (overlay-end overlay) e)))
                 (progn
                   (move-overlay overlay s e)
                   (setq old (cdr old)))
               (setq overlay (make-overlay s e)))
             (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-virtual-edges))
        indent)
    (cua--rectangle-operation (if clear 'clear 'corners) nil t pad nil
      '(lambda (s e l r)
         (move-to-column col pad)
         (if (and (eolp)
                  (< (current-column) col))
             (move-to-column col t))
         (cond
          (to-col (indent-to to-col))
          (ch (insert ch))
          (t (tab-to-tab-stop)))
         (if (cua--rectangle-right-side t)
             (cua--rectangle-insert-col (current-column))
           (setq indent (- (current-column) l))))
      '(lambda (l r)
         (when (and indent (> indent 0))
           (aset cua--rectangle 2 (+ l indent))
           (aset cua--rectangle 3 (+ r indent -1)))))))

;;
;; rectangle functions / actions
;;

(defvar cua--rectangle-initialized nil)

(defun cua-set-rectangle-mark (&optional reopen)
  "Set mark and start in CUA rectangle mode.
With prefix argument, activate previous rectangle if possible."
  (interactive "P")
  (unless cua--rectangle-initialized
    (cua--init-rectangles))
  (when (not cua--rectangle)
    (if (and reopen
             cua--last-rectangle
             (eq (car cua--last-rectangle) (current-buffer)))
        (goto-char (car (cdr cua--last-rectangle)))
      (if (not mark-active)
          (push-mark nil nil t)))
    (cua--activate-rectangle)
    (cua--rectangle-set-corners)
    (setq mark-active t