comparison lisp/emulation/cua-rect.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

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

;; Copyright (C) 1997-2002 Free Software Foundation, Inc.

;; Author: Kim F. Storm <[e-mail]>
;; Keywords: keyboard emulations convenience CUA

;; This file is part of GNU Emacs.

;; 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, 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

;;; Rectangle support

(require 'rect)

;; If non-nil, restrict current region to this rectangle.
;; Value is a vector [top bot left right corner ins pad 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 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-killed-rectangle nil)

;; List of overlays used to display current rectangle.
(defvar cua--rectangle-overlays nil)
(make-variable-buffer-local 'cua--rectangle-overlays)

;; Per-buffer CUA mode undo list.
(defvar cua--undo-list nil)
(make-variable-buffer-local 'cua--undo-list)

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

;;; Rectangle geometry

(defun cua--rectangle-top (&optional val)
  ;; Top of CUA rectangle (buffer position on first line).

        (if (= (aref cua--rectangle 5) 0)
            (1+ (cua--rectangle-right))
          (aref cua--rectangle 5))
      (cua--rectangle-left))))

(defun cua--rectangle-padding (&optional set val)
  ;; Current setting of rectangle padding
  (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

  (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 (&optional pad)
  ;; 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

      (if (<= l r)
          (if (< l r)
              (setq r (1- r)))
        (setq l (prog1 r (setq r l)))
        (goto-char top)
        (move-to-column l pad)
        (setq top (point))
        (goto-char bot)
        (move-to-column r pad)
        (setq bot (point))))
    (vector top bot l r corner 0 pad 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

            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 (cua--rectangle-padding))
    (set-mark (point))
    (goto-char pp)
    (move-to-column pc (cua--rectangle-padding))))

;;; Rectangle resizing

(defun cua--forward-line (n pad)
  ;; Move forward/backward one line.  Returns t if movement.
  (if (or (not pad) (< n 0))
      (= (forward-line n) 0)
    (next-line 1)
    t))

(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)))
    (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))
       (t
        (forward-char 1)
        (cua--rectangle-left (current-column)))))
    (if resized
        (cua--rectangle-resized))))

(defun cua-resize-rectangle-left (n)
  "Resize rectangle to the left."
  (interactive "p")
  (let ((pad (cua--rectangle-padding)) 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))
         (t
          (backward-char 1)
          (cua--rectangle-left (current-column))))
        (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)
    (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)
          (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)
          (cua--rectangle-top t)
          (setq resized t)))))
    (if resized
        (cua--rectangle-resized))))

(defun cua-resize-rectangle-up (n)
  "Resize rectangle upwards."
  (interactive "p")
  (let ((pad (cua--rectangle-padding)) 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)
          (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)
          (cua--rectangle-top t)
          (setq resized t)))))
    (if resized
        (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-padding))
  (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-padding))
  (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)))

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

;;; 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)
  (if (cua--rectangle-padding)
      (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)

  (when cua--rectangle
    (cua--deactivate-rectangle)
    (cua--deactivate t))
  (setq cua--last-rectangle nil)
  (mouse-set-point event)
  (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)

        (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 ((pad (cua--rectangle-padding))
        (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 pad)
        (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)
        (cua--rectangle-bot t)
        (goto-char top)
        (cua--forward-line 1 pad)
        (cua--rectangle-top t)))
     ((eq dir 'left)
      (when (> l 0)
        (cua--rectangle-left (1- l))
        (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--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)
  ;; 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
  ;; Set undo boundary if UNDO is non-nil.
  ;; Rectangle is padded if PAD = t or numeric and (cua--rectangle-padding)
  ;; Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear.
  (let* ((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)))
    (if undo
        (cua--rectangle-undo-boundary))
    (if (integerp pad)
        (setq pad (cua--rectangle-padding)))
    (save-excursion
      (save-restriction
        (widen)
        (when (> (cua--rectangle-corner) 1)
          (goto-char end)
          (and (bolp) (not (eolp)) (not (eobp))
               (setq end (1+ end))))
        (when visible
          (setq start (max (window-start) start))
          (setq end   (min (window-end) end)))
        (goto-char end)
        (setq end (line-end-position))
        (goto-char start)
        (setq start (line-beginning-position))
        (narrow-to-region start end)
        (goto-char (point-min))
        (while (< (point) (point-max))

               (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 (>= (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
		    (unless (eolp)
			(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))))
    (cond
     ((eq keep-clear 'keep)
      (cua--keep-active))
     ((eq keep-clear 'clear)
      (cua--deactivate))

      (cua--keep-active)))
    (setq cua--buffer-and-point-before-command nil)))

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

(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)
  ;; 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))
      (setq below (and (bolp)
                       (or (eolp) (eobp) (= (1+ (point)) (point-max))))))
  (let ((lines rect)
        (insertcolumn (current-column))
        (first t)
        p)
    (while (or lines below)
      (or first
          (if overwrite-mode
              (insert ?\n)
            (forward-line 1)
            (or (bolp) (insert ?\n))
            (move-to-column insertcolumn t)))
      (if (not lines)
          (setq below nil)
        (insert-for-yank (car lines))
        (setq lines (cdr lines))
        (and first (not below)
             (setq p (point))))
      (setq first nil))
    (and p (not overwrite-mode)
         (goto-char p))))

(defun cua--copy-rectangle-as-kill (&optional ring)
  (if cua--register

    (if ring
        (kill-new (mapconcat
                   (function (lambda (row) (concat row "\n")))
                   killed-rectangle "")))))

(defun cua--activate-rectangle (&optional force)
  ;; 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
           (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--last-rectangle nil))

;; (defvar cua-save-point nil)

(defun cua--deactivate-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-padding 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
        '(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)))
             (while (and old
                         (setq overlay (car old))
                         (< (overlay-start overlay) s)
                         (/= (overlay-end overlay) e))
               (delete-overlay overlay)

                          (= (overlay-end overlay) e)))
                 (progn
                   (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))))))
    ;; 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))
        indent)
    (cua--rectangle-operation (if clear 'clear 'corners) nil t pad
      '(lambda (s e l r)
         (move-to-column col pad)
         (if (and (eolp)
                  (< (current-column) col))
             (move-to-column col t))

  (cua--deactivate))

(defun cua-rotate-rectangle ()
  (interactive)
  (cua--rectangle-corner (if (= (cua--rectangle-left) (cua--rectangle-right)) 0 1))
  (cua--rectangle-set-corners))

(defun cua-toggle-rectangle-padding ()
  (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--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-set-corners))
  (cua--keep-active))

(defun cua-open-rectangle ()
  "Blank out CUA rectangle, shifting text right.
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
   '(lambda (s e l r)
      (skip-chars-forward " \t")
      (let ((ws (- (current-column) l))
            (p (point)))
        (skip-chars-backward " \t")

  "Delete all whitespace starting at left edge of CUA rectangle.
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
   '(lambda (s e l r)
      (when arg
        (skip-syntax-backward " " (line-beginning-position))
        (setq s (point)))
      (skip-syntax-forward " " (line-end-position))

(defun cua-blank-rectangle ()
  "Blank out CUA rectangle.
The text previously in the rectangle is overwritten by the blanks."
  (interactive)
  (cua--rectangle-operation 'keep nil nil 1
   '(lambda (s e l r)
      (goto-char e)
      (skip-syntax-forward " " (line-end-position))
      (setq e (point))
      (let ((column (current-column)))

(defun cua-align-rectangle ()
  "Align rectangle lines to left column."
  (interactive)
  (let (x)
    (cua--rectangle-operation 'clear nil t t
     '(lambda (s e l r)
        (let ((b (line-beginning-position)))
          (skip-syntax-backward "^ " b)
          (skip-syntax-backward " " b)
          (setq s (point)))

(defun cua-string-rectangle (string)
  "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
     '(lambda (s e l r)
        (delete-region s e)
        (skip-chars-forward " \t")
        (let ((ws (- (current-column) l)))
          (delete-region s (point))

          (indent-to (+ (current-column) ws))))
     (unless (cua--rectangle-restriction)
       '(lambda (l r)
          (cua--rectangle-right (max l (+ l (length string) -1)))))))

(defun cua-fill-char-rectangle (ch)
  "Replace CUA rectangle contents with CHARACTER."
  (interactive "cFill rectangle with character: ")
  (cua--rectangle-operation 'clear nil t 1
   '(lambda (s e l r)
      (delete-region s e)
      (move-to-column l t)
      (insert-char ch (- 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
     '(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
     '(lambda (s e l r)
        (cond
         ((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t)
          (let* ((txt (buffer-substring-no-properties (match-beginning 1) (match-end 1)))
                 (n (string-to-number txt 16))

                 (fmt (format "%%%s%dd" prefix (length txt))))
            (replace-match (format fmt (+ n increment)))))
         (t nil)))))

(defvar cua--rectangle-seq-format "%d"
  "Last format used by cua-sequence-rectangle.")

(defun cua-sequence-rectangle (first incr fmt)
  "Resequence each line of CUA rectangle starting from FIRST.
The numbers are formatted according to the FORMAT string."
  (interactive
   (list (if current-prefix-arg
             (prefix-numeric-value current-prefix-arg)
           (string-to-number
            (read-string "Start value: (0) " nil nil "0")))
         (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
     '(lambda (s e l r)
         (delete-region s e)
         (insert (format fmt first))
         (setq first (+ first incr)))))

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

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


;;; Replace/rearrange text in current rectangle

(defun cua--rectangle-aux-replace (width adjust keep replace pad format-fct &optional setup-fct)

	(kill-buffer auxbuf))
    (when replace
      (setq z (reverse z))
      (if cua--debug
	  (print z auxbuf))
      (cua--rectangle-operation nil nil t pad
        '(lambda (s e l r)
           (let (cc)
             (goto-char e)
             (skip-chars-forward " \t")
             (setq cc (current-column))

		 (delete-region (point) y)
		 (setq tr (1+ tr)))
	       (setq z (cdr z)))
	     (if cua--debug
		 (print (list (current-column) cc) auxbuf))
             (indent-to cc))))
      (if (> tr 0)
	  (message "Warning:  Truncated %d row%s" tr (if (> tr 1) "s" "")))
      (if adjust
          (cua--rectangle-right (+ (cua--rectangle-left) w -1)))

(defun cua-delete-char-rectangle ()
  "Delete char to left or right of rectangle."
  (interactive)
  (let ((col (cua--rectangle-insert-col))
        (pad (cua--rectangle-padding))
        indent)
    (cua--rectangle-operation 'corners nil t pad
     '(lambda (s e l r)
        (move-to-column
         (if (cua--rectangle-right-side t)
             (max (1+ r) col) l)
         pad)

          (aset cua--rectangle 2 (- l indent))
          (aset cua--rectangle 3 (- r indent 1)))))))

(defun cua-help-for-rectangle (&optional help)
  (interactive)
  (let ((M (if cua-use-hyper-key " H-" " M-")))
    (message
     (concat (if help "C-?:help" "")
             M "p:pad" M "o:open" M "c:close" M "b:blank"
             M "s:string" M "f:fill" M "i:incr" M "n:seq"))))

      (cua--deactivate-rectangle))
  (setq cua--last-rectangle nil))

(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)
    (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))))
      (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))
      (if (cua--rectangle-padding)
          (setq unread-command-events
                (cons (if cua-use-hyper-key ?\H-P ?\M-P) unread-command-events)))))
  (if cua--rectangle
      (if (and mark-active
               (not deactivate-mark))
          (cua--highlight-rectangle)
        (cua--deactivate-rectangle))))


;;; 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 [remap copy-region-as-kill] 'cua-copy-rectangle)
  (define-key cua--rectangle-keymap [remap kill-ring-save]      'cua-copy-rectangle)
  (define-key cua--rectangle-keymap [remap kill-region]         'cua-cut-rectangle)
  (define-key cua--rectangle-keymap [remap delete-char]         'cua-delete-rectangle)

  (cua--rect-M/H-key ?k	'cua-cut-rectangle-as-text)
  (cua--rect-M/H-key ?l	'cua-downcase-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-do-rectangle-padding)
  (cua--rect-M/H-key ?q	'cua-refill-rectangle)
  (cua--rect-M/H-key ?r	'cua-replace-in-rectangle)
  (cua--rect-M/H-key ?R	'cua-reverse-rectangle)
  (cua--rect-M/H-key ?s	'cua-string-rectangle)

  (cua--rect-M/H-key ?'	'cua-restrict-prefix-rectangle)
  (cua--rect-M/H-key ?/	'cua-restrict-regexp-rectangle)

  (setq cua--rectangle-initialized t))

;;; cua-rect.el ends here

88155:d7ddb3e565de

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

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

;; Author: Kim F. Storm <[e-mail]>
;; Keywords: keyboard emulations convenience CUA

;; This file is part of GNU Emacs.

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

;;; 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-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 (= (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

  (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

      (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

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

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

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

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

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

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

    (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 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 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)
                         (/= (overlay-end overlay) e))
               (delete-overlay overlay)

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

  (cua--deactivate))

(defun cua-rotate-rectangle ()
  (interactive)
  (cua--rectangle-corner (if (= (cua--rectangle-left) (cua--rectangle-right)) 0 1))
  (cua--rectangle-set-corners)
  (if (cua--rectangle-virtual-edges)
      (setq cua--buffer-and-point-before-command nil)))

(defun cua-toggle-rectangle-virtual-edges ()
  (interactive)
  (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--rectangle-operation nil nil t t t)
    (cua--rectangle-set-corners))
  (cua--keep-active))

(defun cua-open-rectangle ()
  "Blank out CUA rectangle, shifting text right.
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 nil
   '(lambda (s e l r)
      (skip-chars-forward " \t")
      (let ((ws (- (current-column) l))
            (p (point)))
        (skip-chars-backward " \t")

  "Delete all whitespace starting at left edge of CUA rectangle.
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 nil
   '(lambda (s e l r)
      (when arg
        (skip-syntax-backward " " (line-beginning-position))
        (setq s (point)))
      (skip-syntax-forward " " (line-end-position))

(defun cua-blank-rectangle ()
  "Blank out CUA rectangle.
The text previously in the rectangle is overwritten by the blanks."
  (interactive)
  (cua--rectangle-operation 'keep nil nil 1 nil
   '(lambda (s e l r)
      (goto-char e)
      (skip-syntax-forward " " (line-end-position))
      (setq e (point))
      (let ((column (current-column)))

(defun cua-align-rectangle ()
  "Align rectangle lines to left column."
  (interactive)
  (let (x)
    (cua--rectangle-operation 'clear nil t t nil
     '(lambda (s e l r)
        (let ((b (line-beginning-position)))
          (skip-syntax-backward "^ " b)
          (skip-syntax-backward " " b)
          (setq s (point)))

(defun cua-string-rectangle (string)
  "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 nil
     '(lambda (s e l r)
        (delete-region s e)
        (skip-chars-forward " \t")
        (let ((ws (- (current-column) l)))
          (delete-region s (point))

          (indent-to (+ (current-column) ws))))
     (unless (cua--rectangle-restriction)
       '(lambda (l r)
          (cua--rectangle-right (max l (+ l (length string) -1)))))))

(defun cua-fill-char-rectangle (character)
  "Replace CUA rectangle contents with CHARACTER."
  (interactive "cFill rectangle with character: ")
  (cua--rectangle-operation 'clear nil t 1 nil
   '(lambda (s e l r)
      (delete-region s e)
      (move-to-column l t)
      (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 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 nil
     '(lambda (s e l r)
        (cond
         ((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t)
          (let* ((txt (buffer-substring-no-properties (match-beginning 1) (match-end 1)))
                 (n (string-to-number txt 16))

                 (fmt (format "%%%s%dd" prefix (length txt))))
            (replace-match (format fmt (+ n increment)))))
         (t nil)))))

(defvar cua--rectangle-seq-format "%d"
  "Last format used by `cua-sequence-rectangle'.")

(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
   (list (if current-prefix-arg
             (prefix-numeric-value current-prefix-arg)
           (string-to-number
            (read-string "Start value: (0) " nil nil "0")))
         (string-to-number
          (read-string "Increment: (1) " nil nil "1"))
         (read-string (concat "Format: (" cua--rectangle-seq-format ") "))))
  (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 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--convert-rectangle-as upcase-region nil))

(defun cua-downcase-rectangle ()
  "Convert the rectangle to lower case."
  (interactive)
  (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

(defun cua--rectangle-aux-replace (width adjust keep replace pad format-fct &optional setup-fct)

	(kill-buffer auxbuf))
    (when replace
      (setq z (reverse z))
      (if cua--debug
	  (print z auxbuf))
      (cua--rectangle-operation nil nil t pad nil
        '(lambda (s e l r)
           (let (cc)
             (goto-char e)
             (skip-chars-forward " \t")
             (setq cc (current-column))

		 (delete-region (point) y)
		 (setq tr (1+ tr)))
	       (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" "")))
      (if adjust
          (cua--rectangle-right (+ (cua--rectangle-left) w -1)))

(defun cua-delete-char-rectangle ()
  "Delete char to left or right of rectangle."
  (interactive)
  (let ((col (cua--rectangle-insert-col))
        (pad (cua--rectangle-virtual-edges))
        indent)
    (cua--rectangle-operation 'corners nil t pad nil
     '(lambda (s e l r)
        (move-to-column
         (if (cua--rectangle-right-side t)
             (max (1+ r) col) l)
         pad)

          (aset cua--rectangle 2 (- l indent))
          (aset cua--rectangle 3 (- r indent 1)))))))

(defun cua-help-for-rectangle (&optional help)
  (interactive)
  (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"
             M "s:string" M "f:fill" M "i:incr" M "n:seq"))))

      (cua--deactivate-rectangle))
  (setq cua--last-rectangle nil))

(defun cua--rectangle-post-command ()
  (if cua--restored-rectangle
      (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))))
      (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))))
  (if cua--rectangle
      (if (and mark-active
               (not deactivate-mark))
          (cua--highlight-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--init-rectangles ()
  (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)
  (define-key cua--rectangle-keymap [remap kill-region]         'cua-cut-rectangle)
  (define-key cua--rectangle-keymap [remap delete-char]         'cua-delete-rectangle)

  (cua--rect-M/H-key ?k	'cua-cut-rectangle-as-text)
  (cua--rect-M/H-key ?l	'cua-downcase-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-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)
  (cua--rect-M/H-key ?R	'cua-reverse-rectangle)
  (cua--rect-M/H-key ?s	'cua-string-rectangle)

  (cua--rect-M/H-key ?'	'cua-restrict-prefix-rectangle)
  (cua--rect-M/H-key ?/	'cua-restrict-regexp-rectangle)

  (setq cua--rectangle-initialized t))

;;; arch-tag: b730df53-17b9-4a89-bd63-4a71ec196731
;;; cua-rect.el ends here