lisp/emulation/cua-rect.el

   1 ;;; cua-rect.el --- CUA unified rectangle support
   2
   3 ;; Copyright (C) 1997-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Kim F. Storm <storm@cua.dk>
   6 ;; Keywords: keyboard emulations convenience CUA
   7 ;; Package: cua-base
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Acknowledgments
  25
  26 ;; The rectangle handling and display code borrows from the standard
  27 ;; GNU emacs rect.el package and the rect-mark.el package by Rick
  28 ;; Sladkey <jrs@world.std.com>.
  29
  30 ;;; Commentary:
  31
  32 ;;; Code:
  33
  34 (require 'cua-base)
  35
  36 ;;; Rectangle support
  37
  38 (require 'rect)
  39
  40 ;; If non-nil, restrict current region to this rectangle.
  41 ;; Value is a vector [top bot left right corner ins virt select].
  42 ;; CORNER specifies currently active corner 0=t/l 1=t/r 2=b/l 3=b/r.
  43 ;; INS specifies whether to insert on left(nil) or right(t) side.
  44 ;; If VIRT is non-nil, virtual straight edges are enabled.
  45 ;; If SELECT is a regexp, only lines starting with that regexp are affected.")
  46 (defvar cua--rectangle nil)
  47 (make-variable-buffer-local 'cua--rectangle)
  48
  49 ;; Most recent rectangle geometry.  Note: car is buffer.
  50 (defvar cua--last-rectangle nil)
  51
  52 ;; Rectangle restored by undo.
  53 (defvar cua--restored-rectangle nil)
  54
  55 ;; Last rectangle copied/killed; nil if last kill was not a rectangle.
  56 (defvar cua--last-killed-rectangle nil)
  57
  58 ;; List of overlays used to display current rectangle.
  59 (defvar cua--rectangle-overlays nil)
  60 (make-variable-buffer-local 'cua--rectangle-overlays)
  61 (put 'cua--rectangle-overlays 'permanent-local t)
  62
  63 (defvar cua--overlay-keymap
  64   (let ((map (make-sparse-keymap)))
  65     (define-key map "\r" 'cua-rotate-rectangle)))
  66
  67 (defvar cua--virtual-edges-debug nil)
  68
  69 ;; Undo rectangle commands.
  70
  71 (defvar cua--rect-undo-set-point nil)
  72
  73 (defun cua--rectangle-undo-boundary ()
  74   (when (listp buffer-undo-list)
  75     (let ((s (cua--rect-start-position))
  76           (e (cua--rect-end-position)))
  77       (undo-boundary)
  78       (push (list 'apply 0 s e
  79                   'cua--rect-undo-handler
  80                   (copy-sequence cua--rectangle) t s e)
  81           buffer-undo-list))))
  82
  83 (defun cua--rect-undo-handler (rect on s e)
  84   (if (setq on (not on))
  85       (setq cua--rect-undo-set-point s)
  86     (setq cua--restored-rectangle (copy-sequence rect))
  87     (setq cua--buffer-and-point-before-command nil))
  88   (push (list 'apply 0 s (if on e s)
  89               'cua--rect-undo-handler rect on s e)
  90         buffer-undo-list))
  91
  92 ;;; Rectangle geometry
  93
  94 (defun cua--rectangle-top (&optional val)
  95   ;; Top of CUA rectangle (buffer position on first line).
  96   (if (not val)
  97       (aref cua--rectangle 0)
  98     (setq val (line-beginning-position))
  99     (if (<= val (aref cua--rectangle 1))
 100         (aset cua--rectangle 0 val)
 101       (aset cua--rectangle 1 val)
 102       (cua--rectangle-corner 2))))
 103
 104 (defun cua--rectangle-bot (&optional val)
 105   ;; Bot of CUA rectangle (buffer position on last line).
 106   (if (not val)
 107       (aref cua--rectangle 1)
 108     (setq val (line-end-position))
 109     (if (>= val (aref cua--rectangle 0))
 110         (aset cua--rectangle 1 val)
 111       (aset cua--rectangle 0 val)
 112       (cua--rectangle-corner 2))))
 113
 114 (defun cua--rectangle-left (&optional val)
 115   ;; Left column of CUA rectangle.
 116   (if (integerp val)
 117       (if (<= val (aref cua--rectangle 3))
 118           (aset cua--rectangle 2 val)
 119         (aset cua--rectangle 3 val)
 120         (cua--rectangle-corner (if (cua--rectangle-right-side) -1 1)))
 121     (aref cua--rectangle 2)))
 122
 123 (defun cua--rectangle-right (&optional val)
 124   ;; Right column of CUA rectangle.
 125   (if (integerp val)
 126       (if (>= val (aref cua--rectangle 2))
 127           (aset cua--rectangle 3 val)
 128         (aset cua--rectangle 2 val)
 129         (cua--rectangle-corner (if (cua--rectangle-right-side) -1 1)))
 130     (aref cua--rectangle 3)))
 131
 132 (defun cua--rectangle-corner (&optional advance)
 133   ;; Currently active corner of rectangle.
 134   (let ((c (aref cua--rectangle 4)))
 135     (if (not (integerp advance))
 136         c
 137       (aset cua--rectangle 4
 138             (if (= advance 0)
 139                 (- 3 c) ; opposite corner
 140               (mod (+ c 4 advance) 4)))
 141       (aset cua--rectangle 5 0))))
 142
 143 (defun cua--rectangle-right-side (&optional topbot)
 144   ;; t if point is on right side of rectangle.
 145   (if (and topbot (= (cua--rectangle-left) (cua--rectangle-right)))
 146       (< (cua--rectangle-corner) 2)
 147     (= (mod (cua--rectangle-corner) 2) 1)))
 148
 149 (defun cua--rectangle-column ()
 150   (if (cua--rectangle-right-side)
 151       (cua--rectangle-right)
 152     (cua--rectangle-left)))
 153
 154 (defun cua--rectangle-insert-col (&optional col)
 155   ;; Currently active corner of rectangle.
 156   (if (integerp col)
 157       (aset cua--rectangle 5 col)
 158     (if (cua--rectangle-right-side t)
 159         (if (= (aref cua--rectangle 5) 0)
 160             (1+ (cua--rectangle-right))
 161           (aref cua--rectangle 5))
 162       (cua--rectangle-left))))
 163
 164 (defun cua--rectangle-virtual-edges (&optional set val)
 165   ;; Current setting of rectangle virtual-edges
 166   (if set
 167       (aset cua--rectangle 6 val))
 168   (and ;(not buffer-read-only)
 169        (aref cua--rectangle 6)))
 170
 171 (defun cua--rectangle-restriction (&optional val bounded negated)
 172   ;; Current rectangle restriction
 173   (if val
 174       (aset cua--rectangle 7
 175             (and (stringp val)
 176              (> (length val) 0)
 177              (list val bounded negated)))
 178     (aref cua--rectangle 7)))
 179
 180 (defun cua--rectangle-assert ()
 181   (message "%S (%d)" cua--rectangle (point))
 182   (if (< (cua--rectangle-right) (cua--rectangle-left))
 183       (message "rectangle right < left"))
 184   (if (< (cua--rectangle-bot) (cua--rectangle-top))
 185       (message "rectangle bot < top")))
 186
 187 (defun cua--rectangle-get-corners ()
 188   ;; Calculate the rectangular region represented by point and mark,
 189   ;; putting start in the upper left corner and end in the
 190   ;; bottom right corner.
 191   (let ((top (point)) (bot (mark)) r l corner)
 192     (save-excursion
 193       (goto-char top)
 194       (setq l (current-column))
 195       (goto-char bot)
 196       (setq r (current-column))
 197       (if (<= top bot)
 198           (setq corner (if (<= l r) 0 1))
 199         (setq top (prog1 bot (setq bot top)))
 200         (setq corner (if (<= l r) 2 3)))
 201       (if (<= l r)
 202           (if (< l r)
 203               (setq r (1- r)))
 204         (setq l (prog1 r (setq r l)))
 205         (goto-char top)
 206         (move-to-column l)
 207         (setq top (point))
 208         (goto-char bot)
 209         (move-to-column r)
 210         (setq bot (point))))
 211     (vector top bot l r corner 0 cua-virtual-rectangle-edges nil)))
 212
 213 (defun cua--rectangle-set-corners ()
 214   ;; Set mark and point in opposite corners of current rectangle.
 215   (let (pp pc mp mc (c (cua--rectangle-corner)))
 216     (cond
 217      ((= c 0)  ; top/left -> bot/right
 218       (setq pp (cua--rectangle-top) pc (cua--rectangle-left)
 219             mp (cua--rectangle-bot) mc (cua--rectangle-right)))
 220      ((= c 1)  ; top/right -> bot/left
 221       (setq pp (cua--rectangle-top) pc (cua--rectangle-right)
 222             mp (cua--rectangle-bot) mc (cua--rectangle-left)))
 223      ((= c 2)  ; bot/left -> top/right
 224       (setq pp (cua--rectangle-bot) pc (cua--rectangle-left)
 225             mp (cua--rectangle-top) mc (cua--rectangle-right)))
 226      ((= c 3)  ; bot/right -> top/left
 227       (setq pp (cua--rectangle-bot) pc (cua--rectangle-right)
 228             mp (cua--rectangle-top) mc (cua--rectangle-left))))
 229     (goto-char mp)
 230     (move-to-column mc)
 231     (set-mark (point))
 232     (goto-char pp)
 233     ;; Move cursor inside rectangle, except if char at right edge is a tab.
 234     (if (and (if (cua--rectangle-right-side)
 235                  (and (= (move-to-column pc) (- pc tab-width))
 236                       (not (eolp)))
 237                (> (move-to-column pc) pc))
 238              (not (bolp)))
 239         (backward-char 1))
 240     ))
 241
 242 (defun cua--rect-start-position ()
 243   ;; Return point of top left corner
 244   (save-excursion
 245     (goto-char (cua--rectangle-top))
 246     (and (> (move-to-column (cua--rectangle-left))
 247             (cua--rectangle-left))
 248          (not (bolp))
 249          (backward-char 1))
 250     (point)))
 251
 252 (defun cua--rect-end-position ()
 253   ;; Return point of bottom right cornet
 254   (save-excursion
 255     (goto-char (cua--rectangle-bot))
 256     (and (= (move-to-column (cua--rectangle-right))
 257             (- (cua--rectangle-right) tab-width))
 258          (not (eolp))
 259          (not (bolp))
 260          (backward-char 1))
 261     (point)))
 262
 263 ;;; Rectangle resizing
 264
 265 (defun cua--forward-line (n)
 266   ;; Move forward/backward one line.  Returns t if movement.
 267   (let ((pt (point)))
 268     (and (= (forward-line n) 0)
 269          ;; Deal with end of buffer
 270          (or (not (eobp))
 271              (goto-char pt)))))
 272
 273 (defun cua--rectangle-resized ()
 274   ;; Refresh state after resizing rectangle
 275   (setq cua--buffer-and-point-before-command nil)
 276   (cua--rectangle-insert-col 0)
 277   (cua--rectangle-set-corners)
 278   (cua--keep-active))
 279
 280 (defun cua-resize-rectangle-right (n)
 281   "Resize rectangle to the right."
 282   (interactive "p")
 283   (let ((resized (> n 0)))
 284     (while (> n 0)
 285       (setq n (1- n))
 286       (cond
 287        ((cua--rectangle-right-side)
 288         (cua--rectangle-right (1+ (cua--rectangle-right)))
 289         (move-to-column (cua--rectangle-right)))
 290        (t
 291         (cua--rectangle-left (1+ (cua--rectangle-left)))
 292         (move-to-column (cua--rectangle-right)))))
 293     (if resized
 294         (cua--rectangle-resized))))
 295
 296 (defun cua-resize-rectangle-left (n)
 297   "Resize rectangle to the left."
 298   (interactive "p")
 299   (let (resized)
 300     (while (> n 0)
 301       (setq n (1- n))
 302       (if (or (= (cua--rectangle-right) 0)
 303               (and (not (cua--rectangle-right-side)) (= (cua--rectangle-left) 0)))
 304           (setq n 0)
 305         (cond
 306          ((cua--rectangle-right-side)
 307           (cua--rectangle-right (1- (cua--rectangle-right)))
 308           (move-to-column (cua--rectangle-right)))
 309          (t
 310           (cua--rectangle-left (1- (cua--rectangle-left)))
 311           (move-to-column (cua--rectangle-right))))
 312         (setq resized t)))
 313     (if resized
 314         (cua--rectangle-resized))))
 315
 316 (defun cua-resize-rectangle-down (n)
 317   "Resize rectangle downwards."
 318   (interactive "p")
 319   (let (resized)
 320     (while (> n 0)
 321       (setq n (1- n))
 322       (cond
 323        ((>= (cua--rectangle-corner) 2)
 324         (goto-char (cua--rectangle-bot))
 325         (when (cua--forward-line 1)
 326           (move-to-column (cua--rectangle-column))
 327           (cua--rectangle-bot t)
 328           (setq resized t)))
 329        (t
 330         (goto-char (cua--rectangle-top))
 331         (when (cua--forward-line 1)
 332           (move-to-column (cua--rectangle-column))
 333           (cua--rectangle-top t)
 334           (setq resized t)))))
 335     (if resized
 336         (cua--rectangle-resized))))
 337
 338 (defun cua-resize-rectangle-up (n)
 339   "Resize rectangle upwards."
 340   (interactive "p")
 341   (let (resized)
 342     (while (> n 0)
 343       (setq n (1- n))
 344       (cond
 345        ((>= (cua--rectangle-corner) 2)
 346         (goto-char (cua--rectangle-bot))
 347         (when (cua--forward-line -1)
 348           (move-to-column (cua--rectangle-column))
 349           (cua--rectangle-bot t)
 350           (setq resized t)))
 351        (t
 352         (goto-char (cua--rectangle-top))
 353         (when (cua--forward-line -1)
 354           (move-to-column (cua--rectangle-column))
 355           (cua--rectangle-top t)
 356           (setq resized t)))))
 357     (if resized
 358         (cua--rectangle-resized))))
 359
 360 (defun cua-resize-rectangle-eol ()
 361   "Resize rectangle to end of line."
 362   (interactive)
 363   (unless (eolp)
 364     (end-of-line)
 365     (if (> (current-column) (cua--rectangle-right))
 366         (cua--rectangle-right (current-column)))
 367     (if (not (cua--rectangle-right-side))
 368         (cua--rectangle-corner 1))
 369     (cua--rectangle-resized)))
 370
 371 (defun cua-resize-rectangle-bol ()
 372   "Resize rectangle to beginning of line."
 373   (interactive)
 374   (unless (bolp)
 375     (beginning-of-line)
 376     (cua--rectangle-left (current-column))
 377     (if (cua--rectangle-right-side)
 378         (cua--rectangle-corner -1))
 379     (cua--rectangle-resized)))
 380
 381 (defun cua-resize-rectangle-bot ()
 382   "Resize rectangle to bottom of buffer."
 383   (interactive)
 384   (goto-char (point-max))
 385   (move-to-column (cua--rectangle-column))
 386   (cua--rectangle-bot t)
 387   (cua--rectangle-resized))
 388
 389 (defun cua-resize-rectangle-top ()
 390   "Resize rectangle to top of buffer."
 391   (interactive)
 392   (goto-char (point-min))
 393   (move-to-column (cua--rectangle-column))
 394   (cua--rectangle-top t)
 395   (cua--rectangle-resized))
 396
 397 (defun cua-resize-rectangle-page-up ()
 398   "Resize rectangle upwards by one scroll page."
 399   (interactive)
 400   (scroll-down)
 401   (move-to-column (cua--rectangle-column))
 402   (if (>= (cua--rectangle-corner) 2)
 403       (cua--rectangle-bot t)
 404     (cua--rectangle-top t))
 405   (cua--rectangle-resized))
 406
 407 (defun cua-resize-rectangle-page-down ()
 408   "Resize rectangle downwards by one scroll page."
 409   (interactive)
 410   (scroll-up)
 411   (move-to-column (cua--rectangle-column))
 412   (if (>= (cua--rectangle-corner) 2)
 413       (cua--rectangle-bot t)
 414     (cua--rectangle-top t))
 415   (cua--rectangle-resized))
 416
 417 ;;; Mouse support
 418
 419 ;; This is pretty simplistic, but it does the job...
 420
 421 (defun cua-mouse-resize-rectangle (event)
 422   "Set rectangle corner at mouse click position."
 423   (interactive "e")
 424   (mouse-set-point event)
 425   ;; FIX ME -- need to calculate virtual column.
 426   (if (cua--rectangle-virtual-edges)
 427       (move-to-column (car (posn-col-row (event-end event))) t))
 428   (if (cua--rectangle-right-side)
 429       (cua--rectangle-right (current-column))
 430     (cua--rectangle-left (current-column)))
 431   (if (>= (cua--rectangle-corner) 2)
 432       (cua--rectangle-bot t)
 433     (cua--rectangle-top t))
 434   (cua--rectangle-resized))
 435
 436 (defvar cua--mouse-last-pos nil)
 437
 438 (defun cua-mouse-set-rectangle-mark (event)
 439   "Start rectangle at mouse click position."
 440   (interactive "e")
 441   (when cua--rectangle
 442     (cua--deactivate-rectangle)
 443     (cua--deactivate t))
 444   (setq cua--last-rectangle nil)
 445   (mouse-set-point event)
 446   ;; FIX ME -- need to calculate virtual column.
 447   (cua-set-rectangle-mark)
 448   (setq cua--buffer-and-point-before-command nil)
 449   (setq cua--mouse-last-pos nil))
 450
 451 (defun cua-mouse-save-then-kill-rectangle (event arg)
 452   "Expand rectangle to mouse click position and copy rectangle.
 453 If command is repeated at same position, delete the rectangle."
 454   (interactive "e\nP")
 455   (if (and (eq this-command last-command)
 456            (eq (point) (car-safe cua--mouse-last-pos))
 457            (eq cua--last-killed-rectangle (cdr-safe cua--mouse-last-pos)))
 458       (progn
 459         (unless buffer-read-only
 460           (cua--delete-rectangle))
 461         (cua--deactivate))
 462     (cua-mouse-resize-rectangle event)
 463     (let ((cua-keep-region-after-copy t))
 464       (cua-copy-rectangle arg)
 465       (setq cua--mouse-last-pos (cons (point) cua--last-killed-rectangle)))))
 466
 467 (defun cua--mouse-ignore (_event)
 468   (interactive "e")
 469   (setq this-command last-command))
 470
 471 (defun cua--rectangle-move (dir)
 472   (let ((moved t)
 473         (top (cua--rectangle-top))
 474         (bot (cua--rectangle-bot))
 475         (l (cua--rectangle-left))
 476         (r (cua--rectangle-right)))
 477     (cond
 478      ((eq dir 'up)
 479       (goto-char top)
 480       (when (cua--forward-line -1)
 481         (cua--rectangle-top t)
 482         (goto-char bot)
 483         (forward-line -1)
 484         (cua--rectangle-bot t)))
 485      ((eq dir 'down)
 486       (goto-char bot)
 487       (when (cua--forward-line 1)
 488         (cua--rectangle-bot t)
 489         (goto-char top)
 490         (cua--forward-line 1)
 491         (cua--rectangle-top t)))
 492      ((eq dir 'left)
 493       (when (> l 0)
 494         (cua--rectangle-left (1- l))
 495         (cua--rectangle-right (1- r))))
 496      ((eq dir 'right)
 497       (cua--rectangle-right (1+ r))
 498       (cua--rectangle-left (1+ l)))
 499      (t
 500       (setq moved nil)))
 501     (when moved
 502       (setq cua--buffer-and-point-before-command nil)
 503       (cua--rectangle-set-corners)
 504       (cua--keep-active))))
 505
 506
 507 ;;; Operations on current rectangle
 508
 509 (defun cua--tabify-start (start end)
 510   ;; Return position where auto-tabify should start (or nil if not required).
 511   (save-excursion
 512     (save-restriction
 513       (widen)
 514       (and (not buffer-read-only)
 515            cua-auto-tabify-rectangles
 516            (if (or (not (integerp cua-auto-tabify-rectangles))
 517                    (= (point-min) (point-max))
 518                    (progn
 519                      (goto-char (max (point-min)
 520                                      (- start cua-auto-tabify-rectangles)))
 521                      (search-forward "\t" (min (point-max)
 522                                                (+ end cua-auto-tabify-rectangles)) t)))
 523                start)))))
 524
 525 (defun cua--rectangle-operation (keep-clear visible undo pad tabify &optional fct post-fct)
 526   ;; Call FCT for each line of region with 4 parameters:
 527   ;; Region start, end, left-col, right-col
 528   ;; Point is at start when FCT is called
 529   ;; Call fct with (s,e) = whole lines if VISIBLE non-nil.
 530   ;; Only call fct for visible lines if VISIBLE==t.
 531   ;; Set undo boundary if UNDO is non-nil.
 532   ;; Rectangle is padded if PAD = t or numeric and (cua--rectangle-virtual-edges)
 533   ;; Perform auto-tabify after operation if TABIFY is non-nil.
 534   ;; Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear.
 535   (let* ((inhibit-field-text-motion t)
 536          (start (cua--rectangle-top))
 537          (end   (cua--rectangle-bot))
 538          (l (cua--rectangle-left))
 539          (r (1+ (cua--rectangle-right)))
 540          (m (make-marker))
 541          (tabpad (and (integerp pad) (= pad 2)))
 542          (sel (cua--rectangle-restriction))
 543          (tabify-start (and tabify (cua--tabify-start start end))))
 544     (if undo
 545         (cua--rectangle-undo-boundary))
 546     (if (integerp pad)
 547         (setq pad (cua--rectangle-virtual-edges)))
 548     (save-excursion
 549       (save-restriction
 550         (widen)
 551         (when (> (cua--rectangle-corner) 1)
 552           (goto-char end)
 553           (and (bolp) (not (eolp)) (not (eobp))
 554                (setq end (1+ end))))
 555         (when (eq visible t)
 556           (setq start (max (window-start) start))
 557           (setq end   (min (window-end) end)))
 558         (goto-char end)
 559         (setq end (line-end-position))
 560         (if (and visible (bolp) (not (eobp)))
 561             (setq end (1+ end)))
 562         (goto-char start)
 563         (setq start (line-beginning-position))
 564         (narrow-to-region start end)
 565         (goto-char (point-min))
 566         (while (< (point) (point-max))
 567           (move-to-column r pad)
 568           (and (not pad) (not visible) (> (current-column) r)
 569                (backward-char 1))
 570           (if (and tabpad (not pad) (looking-at "\t"))
 571               (forward-char 1))
 572           (set-marker m (point))
 573           (move-to-column l pad)
 574           (if (and fct (or visible (and (>= (current-column) l) (<= (current-column) r))))
 575               (let ((v t) (p (point)))
 576                 (when sel
 577                   (if (car (cdr sel))
 578                       (setq v (looking-at (car sel)))
 579                     (setq v (re-search-forward (car sel) m t))
 580                     (goto-char p))
 581                   (if (car (cdr (cdr sel)))
 582                       (setq v (null v))))
 583                 (if visible
 584                     (funcall fct p m l r v)
 585                   (if v
 586                       (funcall fct p m l r)))))
 587           (set-marker m nil)
 588           (forward-line 1))
 589         (if (not visible)
 590             (cua--rectangle-bot t))
 591         (if post-fct
 592             (funcall post-fct l r))
 593         (when tabify-start
 594           (tabify tabify-start (point)))))
 595     (cond
 596      ((eq keep-clear 'keep)
 597       (cua--keep-active))
 598      ((eq keep-clear 'clear)
 599       (cua--deactivate))
 600      ((eq keep-clear 'corners)
 601       (cua--rectangle-set-corners)
 602       (cua--keep-active)))
 603     (setq cua--buffer-and-point-before-command nil)))
 604
 605 (put 'cua--rectangle-operation 'lisp-indent-function 4)
 606
 607 (defun cua--delete-rectangle ()
 608   (let ((lines 0))
 609     (if (not (cua--rectangle-virtual-edges))
 610         (cua--rectangle-operation nil nil t 2 t
 611           (lambda (s e _l _r _v)
 612             (setq lines (1+ lines))
 613             (if (and (> e s) (<= e (point-max)))
 614                 (delete-region s e))))
 615       (cua--rectangle-operation nil 1 t nil t
 616         (lambda (s e _l _r _v)
 617            (setq lines (1+ lines))
 618            (when (and (> e s) (<= e (point-max)))
 619              (delete-region s e)))))
 620     lines))
 621
 622 (defun cua--extract-rectangle ()
 623   (let (rect)
 624     (if (not (cua--rectangle-virtual-edges))
 625         (cua--rectangle-operation nil nil nil nil nil ; do not tabify
 626           (lambda (s e _l _r)
 627              (setq rect (cons (cua--filter-buffer-noprops s e) rect))))
 628       (cua--rectangle-operation nil 1 nil nil nil ; do not tabify
 629         (lambda (s e l r _v)
 630            (let ((copy t) (bs 0) (as 0) row)
 631              (if (= s e) (setq e (1+ e)))
 632              (goto-char s)
 633              (move-to-column l)
 634              (if (= (point) (line-end-position))
 635                  (setq bs (- r l)
 636                        copy nil)
 637                (skip-chars-forward "\s\t" e)
 638                (setq bs (- (min r (current-column)) l)
 639                      s (point))
 640                (move-to-column r)
 641                (skip-chars-backward "\s\t" s)
 642                (setq as (- r (max (current-column) l))
 643                      e (point)))
 644              (setq row (if (and copy (> e s))
 645                            (cua--filter-buffer-noprops s e)
 646                          ""))
 647              (when (> bs 0)
 648                (setq row (concat (make-string bs ?\s) row)))
 649              (when (> as 0)
 650                (setq row (concat row (make-string as ?\s))))
 651              (setq rect (cons row rect))))))
 652     (nreverse rect)))
 653
 654 (defun cua--insert-rectangle (rect &optional below paste-column line-count)
 655   ;; Insert rectangle as insert-rectangle, but don't set mark and exit with
 656   ;; point at either next to top right or below bottom left corner
 657   ;; Notice: In overwrite mode, the rectangle is inserted as separate text lines.
 658   (if (eq below 'auto)
 659       (setq below (and (bolp)
 660                        (or (eolp) (eobp) (= (1+ (point)) (point-max))))))
 661   (unless paste-column
 662     (setq paste-column (current-column)))
 663   (let ((lines rect)
 664         (first t)
 665         (tabify-start (cua--tabify-start (point) (point)))
 666         last-column
 667         p)
 668     (while (or lines below)
 669       (or first
 670           (if overwrite-mode
 671               (insert ?\n)
 672             (forward-line 1)
 673             (or (bolp) (insert ?\n))))
 674       (unless overwrite-mode
 675         (move-to-column paste-column t))
 676       (if (not lines)
 677           (setq below nil)
 678         (insert-for-yank (car lines))
 679         (unless last-column
 680           (setq last-column (current-column)))
 681         (setq lines (cdr lines))
 682         (and first (not below)
 683              (setq p (point))))
 684       (setq first nil)
 685       (if (and line-count (= (setq line-count (1- line-count)) 0))
 686           (setq lines nil)))
 687     (when (and line-count last-column (not overwrite-mode))
 688       (while (> line-count 0)
 689         (forward-line 1)
 690         (or (bolp) (insert ?\n))
 691         (move-to-column paste-column t)
 692         (insert-char ?\s (- last-column paste-column -1))
 693         (setq line-count (1- line-count))))
 694     (when (and tabify-start
 695                (not overwrite-mode))
 696       (tabify tabify-start (point)))
 697     (and p (not overwrite-mode)
 698          (goto-char p))))
 699
 700 (defun cua--copy-rectangle-as-kill (&optional ring)
 701   (if cua--register
 702       (set-register cua--register (cua--extract-rectangle))
 703     (setq killed-rectangle (cua--extract-rectangle))
 704     (setq cua--last-killed-rectangle (cons (and kill-ring (car kill-ring)) killed-rectangle))
 705     (if ring
 706         (kill-new (mapconcat
 707                    (function (lambda (row) (concat row "\n")))
 708                    killed-rectangle "")))))
 709
 710 (defun cua--activate-rectangle ()
 711   ;; Turn on rectangular marking mode by disabling transient mark mode
 712   ;; and manually handling highlighting from a post command hook.
 713   ;; Be careful if we are already marking a rectangle.
 714   (setq cua--rectangle
 715         (if (and cua--last-rectangle
 716                  (eq (car cua--last-rectangle) (current-buffer))
 717                  (eq (car (cdr cua--last-rectangle)) (point)))
 718             (cdr (cdr cua--last-rectangle))
 719           (cua--rectangle-get-corners))
 720         cua--status-string (if (cua--rectangle-virtual-edges) " [R]" "")
 721         cua--last-rectangle nil))
 722
 723 ;; (defvar cua-save-point nil)
 724
 725 (defun cua--deactivate-rectangle ()
 726   ;; This is used to clean up after `cua--activate-rectangle'.
 727   (mapc (function delete-overlay) cua--rectangle-overlays)
 728   (setq cua--last-rectangle (cons (current-buffer)
 729                                   (cons (point) ;; cua-save-point
 730                                         cua--rectangle))
 731         cua--rectangle nil
 732         cua--rectangle-overlays nil
 733         cua--status-string nil
 734         cua--mouse-last-pos nil))
 735
 736 (defun cua--highlight-rectangle ()
 737   ;; This function is used to highlight the rectangular region.
 738   ;; We do this by putting an overlay on each line within the rectangle.
 739   ;; Each overlay extends across all the columns of the rectangle.
 740   ;; We try to reuse overlays where possible because this is more efficient
 741   ;; and results in less flicker.
 742   ;; If cua--rectangle-virtual-edges is nil and the buffer contains tabs or short lines,
 743   ;; the highlighted region may not be perfectly rectangular.
 744   (let ((deactivate-mark deactivate-mark)
 745         (old cua--rectangle-overlays)
 746         (new nil)
 747         (left (cua--rectangle-left))
 748         (right (1+ (cua--rectangle-right))))
 749     (when (/= left right)
 750       (sit-for 0)  ; make window top/bottom reliable
 751       (cua--rectangle-operation nil t nil nil nil ; do not tabify
 752         (lambda (s e l r v)
 753            (let ((rface (if v 'cua-rectangle 'cua-rectangle-noselect))
 754                  overlay bs ms as)
 755              (when (cua--rectangle-virtual-edges)
 756                (let ((lb (line-beginning-position))
 757                      (le (line-end-position))
 758                      cl cl0 pl cr cr0 pr)
 759                  (goto-char s)
 760                  (setq cl (move-to-column l)
 761                        pl (point))
 762                  (setq cr (move-to-column r)
 763                        pr (point))
 764                  (if (= lb pl)
 765                      (setq cl0 0)
 766                    (goto-char (1- pl))
 767                    (setq cl0 (current-column)))
 768                  (if (= lb le)
 769                      (setq cr0 0)
 770                    (goto-char (1- pr))
 771                    (setq cr0 (current-column)))
 772                  (unless (and (= cl l) (= cr r))
 773                    (when (/= cl l)
 774                      (setq bs (propertize
 775                                (make-string
 776                                 (- l cl0 (if (and (= le pl) (/= le lb)) 1 0))
 777                                 (if cua--virtual-edges-debug ?. ?\s))
 778                                'face (or (get-text-property (1- s) 'face) 'default)))
 779                      (if (/= pl le)
 780                          (setq s (1- s))))
 781                    (cond
 782                     ((= cr r)
 783                      (if (and (/= pr le)
 784                               (/= cr0 (1- cr))
 785                               (or bs (/= cr0 (- cr tab-width)))
 786                               (/= (mod cr tab-width) 0))
 787                          (setq e (1- e))))
 788                     ((= cr cl)
 789                      (setq ms (propertize
 790                                (make-string
 791                                 (- r l)
 792                                 (if cua--virtual-edges-debug ?, ?\s))
 793                                'face rface))
 794                      (if (cua--rectangle-right-side)
 795                          (put-text-property (1- (length ms)) (length ms) 'cursor 2 ms)
 796                        (put-text-property 0 1 'cursor 2 ms))
 797                      (setq bs (concat bs ms))
 798                      (setq rface nil))
 799                     (t
 800                      (setq as (propertize
 801                                (make-string
 802                                 (- r cr0 (if (= le pr) 1 0))
 803                                 (if cua--virtual-edges-debug ?~ ?\s))
 804                                'face rface))
 805                      (if (cua--rectangle-right-side)
 806                          (put-text-property (1- (length as)) (length as) 'cursor 2 as)
 807                        (put-text-property 0 1 'cursor 2 as))
 808                      (if (/= pr le)
 809                          (setq e (1- e))))))))
 810              ;; Trim old leading overlays.
 811              (while (and old
 812                          (setq overlay (car old))
 813                          (< (overlay-start overlay) s)
 814                          (/= (overlay-end overlay) e))
 815                (delete-overlay overlay)
 816                (setq old (cdr old)))
 817              ;; Reuse an overlay if possible, otherwise create one.
 818              (if (and old
 819                       (setq overlay (car old))
 820                       (or (= (overlay-start overlay) s)
 821                           (= (overlay-end overlay) e)))
 822                  (progn
 823                    (move-overlay overlay s e)
 824                    (setq old (cdr old)))
 825                (setq overlay (make-overlay s e)))
 826              (overlay-put overlay 'before-string bs)
 827              (overlay-put overlay 'after-string as)
 828              (overlay-put overlay 'face rface)
 829              (overlay-put overlay 'keymap cua--overlay-keymap)
 830              (overlay-put overlay 'window (selected-window))
 831              (setq new (cons overlay new))))))
 832     ;; Trim old trailing overlays.
 833     (mapc (function delete-overlay) old)
 834     (setq cua--rectangle-overlays (nreverse new))))
 835
 836 (defun cua--indent-rectangle (&optional ch to-col clear)
 837   ;; Indent current rectangle.
 838   (let ((col (cua--rectangle-insert-col))
 839         (pad (cua--rectangle-virtual-edges))
 840         indent)
 841     (cua--rectangle-operation (if clear 'clear 'corners) nil t pad nil
 842       (lambda (_s _e l _r)
 843          (move-to-column col pad)
 844          (if (and (eolp)
 845                   (< (current-column) col))
 846              (move-to-column col t))
 847          (cond
 848           (to-col (indent-to to-col))
 849           ((and ch (not (eq ch ?\t))) (insert ch))
 850           (t (tab-to-tab-stop)))
 851          (if (cua--rectangle-right-side t)
 852              (cua--rectangle-insert-col (current-column))
 853            (setq indent (- (current-column) l))))
 854       (lambda (l r)
 855          (when (and indent (> indent 0))
 856            (aset cua--rectangle 2 (+ l indent))
 857            (aset cua--rectangle 3 (+ r indent -1)))))))
 858
 859 ;;
 860 ;; rectangle functions / actions
 861 ;;
 862
 863 (defvar cua--rectangle-initialized nil)
 864
 865 (defun cua-set-rectangle-mark (&optional reopen)
 866   "Set mark and start in CUA rectangle mode.
 867 With prefix argument, activate previous rectangle if possible."
 868   (interactive "P")
 869   (unless cua--rectangle-initialized
 870     (cua--init-rectangles))
 871   (when (not cua--rectangle)
 872     (if (and reopen
 873              cua--last-rectangle
 874              (eq (car cua--last-rectangle) (current-buffer)))
 875         (goto-char (car (cdr cua--last-rectangle)))
 876       (if (not mark-active)
 877           (push-mark nil nil t)))
 878     (cua--activate-rectangle)
 879     (cua--rectangle-set-corners)
 880     (setq mark-active t
 881           cua--explicit-region-start t)
 882     (if cua-enable-rectangle-auto-help
 883         (cua-help-for-rectangle t))))
 884
 885 (defun cua-clear-rectangle-mark ()
 886   "Cancel current rectangle."
 887   (interactive)
 888   (when cua--rectangle
 889     (setq mark-active nil
 890           cua--explicit-region-start nil)
 891     (cua--deactivate-rectangle)))
 892
 893 (defun cua-toggle-rectangle-mark ()
 894   (interactive)
 895   (if cua--rectangle
 896       (cua--deactivate-rectangle)
 897     (unless cua--rectangle-initialized
 898       (cua--init-rectangles))
 899     (cua--activate-rectangle))
 900   (if cua--rectangle
 901       (if cua-enable-rectangle-auto-help
 902           (cua-help-for-rectangle t))
 903     (if cua-enable-region-auto-help
 904         (cua-help-for-region t))))
 905
 906 (defun cua-restrict-regexp-rectangle (arg)
 907   "Restrict rectangle to lines (not) matching regexp.
 908 With prefix argument, toggle restriction."
 909   (interactive "P")
 910   (let ((r (cua--rectangle-restriction)))
 911     (if (and r (null (car (cdr r))))
 912       (if arg
 913           (cua--rectangle-restriction (car r) nil (not (car (cdr (cdr r)))))
 914         (cua--rectangle-restriction "" nil nil))
 915       (cua--rectangle-restriction
 916        (read-from-minibuffer "Restrict rectangle (regexp): "
 917                              nil nil nil nil) nil arg))))
 918
 919 (defun cua-restrict-prefix-rectangle (arg)
 920   "Restrict rectangle to lines (not) starting with CHAR.
 921 With prefix argument, toggle restriction."
 922   (interactive "P")
 923   (let ((r (cua--rectangle-restriction)))
 924     (if (and r (car (cdr r)))
 925       (if arg
 926           (cua--rectangle-restriction (car r) t (not (car (cdr (cdr r)))))
 927         (cua--rectangle-restriction "" nil nil))
 928       (cua--rectangle-restriction
 929        (format "[%c]"
 930                (read-char "Restrictive rectangle (char): ")) t arg))))
 931
 932 (defun cua-move-rectangle-up ()
 933   (interactive)
 934   (cua--rectangle-move 'up))
 935
 936 (defun cua-move-rectangle-down ()
 937   (interactive)
 938   (cua--rectangle-move 'down))
 939
 940 (defun cua-move-rectangle-left ()
 941   (interactive)
 942   (cua--rectangle-move 'left))
 943
 944 (defun cua-move-rectangle-right ()
 945   (interactive)
 946   (cua--rectangle-move 'right))
 947
 948 (defun cua-copy-rectangle (arg)
 949   (interactive "P")
 950   (setq arg (cua--prefix-arg arg))
 951   (cua--copy-rectangle-as-kill arg)
 952   (if cua-keep-region-after-copy
 953       (cua--keep-active)
 954     (cua--deactivate)))
 955
 956 (defun cua-cut-rectangle (arg)
 957   (interactive "P")
 958   (if buffer-read-only
 959       (cua-copy-rectangle arg)
 960     (setq arg (cua--prefix-arg arg))
 961     (goto-char (min (mark) (point)))
 962     (cua--copy-rectangle-as-kill arg)
 963     (cua--delete-rectangle))
 964   (cua--deactivate))
 965
 966 (defun cua-delete-rectangle ()
 967   (interactive)
 968   (goto-char (min (point) (mark)))
 969   (if cua-delete-copy-to-register-0
 970       (set-register ?0 (cua--extract-rectangle)))
 971   (cua--delete-rectangle)
 972   (cua--deactivate))
 973
 974 (defun cua-rotate-rectangle ()
 975   (interactive)
 976   (cua--rectangle-corner (if (= (cua--rectangle-left) (cua--rectangle-right)) 0 1))
 977   (cua--rectangle-set-corners)
 978   (if (cua--rectangle-virtual-edges)
 979       (setq cua--buffer-and-point-before-command nil)))
 980
 981 (defun cua-toggle-rectangle-virtual-edges ()
 982   (interactive)
 983   (cua--rectangle-virtual-edges t (not (cua--rectangle-virtual-edges)))
 984   (cua--rectangle-set-corners)
 985   (setq cua--status-string (and (cua--rectangle-virtual-edges) " [R]"))
 986   (cua--keep-active))
 987
 988 (defun cua-do-rectangle-padding ()
 989   (interactive)
 990   (if buffer-read-only
 991       (message "Cannot do padding in read-only buffer")
 992     (cua--rectangle-operation nil nil t t t)
 993     (cua--rectangle-set-corners))
 994   (cua--keep-active))
 995
 996 (defun cua-open-rectangle ()
 997   "Blank out CUA rectangle, shifting text right.
 998 The text previously in the region is not overwritten by the blanks,
 999 but instead winds up to the right of the rectangle."
1000   (interactive)
1001   (cua--rectangle-operation 'corners nil t 1 nil
1002    (lambda (_s _e l r)
1003       (skip-chars-forward " \t")
1004       (let ((ws (- (current-column) l))
1005             (p (point)))
1006         (skip-chars-backward " \t")
1007         (delete-region (point) p)
1008         (indent-to (+ r ws))))))
1009
1010 (defun cua-close-rectangle (arg)
1011   "Delete all whitespace starting at left edge of CUA rectangle.
1012 On each line in the rectangle, all continuous whitespace starting
1013 at that column is deleted.
1014 With prefix arg, also delete whitespace to the left of that column."
1015   (interactive "P")
1016   (cua--rectangle-operation 'clear nil t 1 nil
1017    (lambda (s _e _l _r)
1018       (when arg
1019         (skip-syntax-backward " " (line-beginning-position))
1020         (setq s (point)))
1021       (skip-syntax-forward " " (line-end-position))
1022       (delete-region s (point)))))
1023
1024 (defun cua-blank-rectangle ()
1025   "Blank out CUA rectangle.
1026 The text previously in the rectangle is overwritten by the blanks."
1027   (interactive)
1028   (cua--rectangle-operation 'keep nil nil 1 nil
1029    (lambda (s e _l _r)
1030       (goto-char e)
1031       (skip-syntax-forward " " (line-end-position))
1032       (setq e (point))
1033       (let ((column (current-column)))
1034         (goto-char s)
1035         (skip-syntax-backward " " (line-beginning-position))
1036         (delete-region (point) e)
1037         (indent-to column)))))
1038
1039 (defun cua-align-rectangle ()
1040   "Align rectangle lines to left column."
1041   (interactive)
1042   (cua--rectangle-operation 'clear nil t t nil
1043    (lambda (s _e l _r)
1044       (let ((b (line-beginning-position)))
1045         (skip-syntax-backward "^ " b)
1046         (skip-syntax-backward " " b)
1047         (setq s (point)))
1048       (skip-syntax-forward " " (line-end-position))
1049       (delete-region s (point))
1050       (indent-to l))
1051    (lambda (l _r)
1052       (move-to-column l)
1053       ;; (setq cua-save-point (point))
1054       )))
1055
1056 (declare-function cua--cut-rectangle-to-global-mark  "cua-gmrk" (as-text))
1057 (declare-function cua--copy-rectangle-to-global-mark "cua-gmrk" (as-text))
1058
1059 (defun cua-copy-rectangle-as-text (&optional arg delete)
1060   "Copy rectangle, but store as normal text."
1061   (interactive "P")
1062   (if cua--global-mark-active
1063       (if delete
1064           (cua--cut-rectangle-to-global-mark t)
1065         (cua--copy-rectangle-to-global-mark t))
1066     (let* ((rect (cua--extract-rectangle))
1067            (text (mapconcat
1068                   (function (lambda (row) (concat row "\n")))
1069                   rect "")))
1070       (setq arg (cua--prefix-arg arg))
1071       (if cua--register
1072           (set-register cua--register text)
1073         (kill-new text)))
1074     (if delete
1075         (cua--delete-rectangle))
1076     (cua--deactivate)))
1077
1078 (defun cua-cut-rectangle-as-text (arg)
1079   "Kill rectangle, but store as normal text."
1080   (interactive "P")
1081   (cua-copy-rectangle-as-text arg (not buffer-read-only)))
1082
1083 (defun cua-string-rectangle (string)
1084   "Replace CUA rectangle contents with STRING on each line.
1085 The length of STRING need not be the same as the rectangle width."
1086   (interactive "sString rectangle: ")
1087   (cua--rectangle-operation 'keep nil t t nil
1088      (lambda (s e l _r)
1089         (delete-region s e)
1090         (skip-chars-forward " \t")
1091         (let ((ws (- (current-column) l)))
1092           (delete-region s (point))
1093           (insert string)
1094           (indent-to (+ (current-column) ws))))
1095      (unless (cua--rectangle-restriction)
1096        (lambda (l _r)
1097           (cua--rectangle-right (max l (+ l (length string) -1)))))))
1098
1099 (defun cua-fill-char-rectangle (character)
1100   "Replace CUA rectangle contents with CHARACTER."
1101   (interactive "cFill rectangle with character: ")
1102   (cua--rectangle-operation 'clear nil t 1 nil
1103    (lambda (s e l r)
1104       (delete-region s e)
1105       (move-to-column l t)
1106       (insert-char character (- r l)))))
1107
1108 (defun cua-replace-in-rectangle (regexp newtext)
1109   "Replace REGEXP with NEWTEXT in each line of CUA rectangle."
1110   (interactive "sReplace regexp: \nsNew text: ")
1111   (if buffer-read-only
1112       (message "Cannot replace in read-only buffer")
1113     (cua--rectangle-operation 'keep nil t 1 nil
1114      (lambda (_s e _l _r)
1115         (if (re-search-forward regexp e t)
1116             (replace-match newtext nil nil))))))
1117
1118 (defun cua-incr-rectangle (increment)
1119   "Increment each line of CUA rectangle by prefix amount."
1120   (interactive "p")
1121   (cua--rectangle-operation 'keep nil t 1 nil
1122      (lambda (_s e _l _r)
1123         (cond
1124          ((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t)
1125           (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1)))
1126                  (n (string-to-number txt 16))
1127                  (fmt (format "0x%%0%dx" (length txt))))
1128             (replace-match (format fmt (+ n increment)))))
1129          ((re-search-forward "\\( *-?[0-9]+\\)" e t)
1130           (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1)))
1131                  (prefix (if (= (aref txt 0) ?0) "0" ""))
1132                  (n (string-to-number txt 10))
1133                  (fmt (format "%%%s%dd" prefix (length txt))))
1134             (replace-match (format fmt (+ n increment)))))
1135          (t nil)))))
1136
1137 (defvar cua--rectangle-seq-format "%d"
1138   "Last format used by `cua-sequence-rectangle'.")
1139
1140 (defun cua-sequence-rectangle (first incr format)
1141   "Resequence each line of CUA rectangle starting from FIRST.
1142 The numbers are formatted according to the FORMAT string."
1143   (interactive
1144    (list (if current-prefix-arg
1145              (prefix-numeric-value current-prefix-arg)
1146            (string-to-number
1147             (read-string "Start value: (0) " nil nil "0")))
1148          (string-to-number
1149           (read-string "Increment: (1) " nil nil "1"))
1150          (read-string (concat "Format: (" cua--rectangle-seq-format ") "))))
1151   (if (= (length format) 0)
1152       (setq format cua--rectangle-seq-format)
1153     (setq cua--rectangle-seq-format format))
1154   (cua--rectangle-operation 'clear nil t 1 nil
1155      (lambda (s e _l _r)
1156          (delete-region s e)
1157          (insert (format format first))
1158          (setq first (+ first incr)))))
1159
1160 (defmacro cua--convert-rectangle-as (command tabify)
1161   `(cua--rectangle-operation 'clear nil nil nil ,tabify
1162     (lambda (s e _l _r)
1163        (,command s e))))
1164
1165 (defun cua-upcase-rectangle ()
1166   "Convert the rectangle to upper case."
1167   (interactive)
1168   (cua--convert-rectangle-as upcase-region nil))
1169
1170 (defun cua-downcase-rectangle ()
1171   "Convert the rectangle to lower case."
1172   (interactive)
1173   (cua--convert-rectangle-as downcase-region nil))
1174
1175 (defun cua-upcase-initials-rectangle ()
1176   "Convert the rectangle initials to upper case."
1177   (interactive)
1178   (cua--convert-rectangle-as upcase-initials-region nil))
1179
1180 (defun cua-capitalize-rectangle ()
1181   "Convert the rectangle to proper case."
1182   (interactive)
1183   (cua--convert-rectangle-as capitalize-region nil))
1184
1185
1186 ;;; Replace/rearrange text in current rectangle
1187
1188 (defun cua--rectangle-aux-replace (width adjust keep replace pad format-fct &optional setup-fct)
1189   ;; Process text inserted by calling SETUP-FCT or current rectangle if nil.
1190   ;; Then call FORMAT-FCT on text (if non-nil); takes two args: start and end.
1191   ;; Fill to WIDTH characters if > 0 or fill to current width if == 0.
1192   ;; Don't fill if WIDTH < 0.
1193   ;; Replace current rectangle by filled text if REPLACE is non-nil
1194   (let ((auxbuf (get-buffer-create "*CUA temp*"))
1195         (w (if (> width 1) width
1196              (- (cua--rectangle-right) (cua--rectangle-left) -1)))
1197         (r (or setup-fct (cua--extract-rectangle)))
1198         y z (tr 0))
1199     (with-current-buffer auxbuf
1200       (erase-buffer)
1201       (if setup-fct
1202           (funcall setup-fct)
1203         (cua--insert-rectangle r))
1204       (if format-fct
1205           (let ((fill-column w))
1206             (funcall format-fct (point-min) (point-max))))
1207       (when replace
1208         (goto-char (point-min))
1209         (while (not (eobp))
1210           (setq z (cons (filter-buffer-substring (point) (line-end-position)) z))
1211           (forward-line 1))))
1212     (if (not cua--debug)
1213         (kill-buffer auxbuf))
1214     (when replace
1215       (setq z (reverse z))
1216       (if cua--debug
1217           (print z auxbuf))
1218       (cua--rectangle-operation nil nil t pad nil
1219         (lambda (s e l _r)
1220            (let (cc)
1221              (goto-char e)
1222              (skip-chars-forward " \t")
1223              (setq cc (current-column))
1224              (if cua--debug
1225                  (print (list cc s e) auxbuf))
1226              (delete-region s (point))
1227              (if (not z)
1228                  (setq y 0)
1229                (move-to-column l t)
1230                (insert (car z))
1231                (when (> (current-column) (+ l w))
1232                  (setq y (point))
1233                  (move-to-column (+ l w) t)
1234                  (delete-region (point) y)
1235                  (setq tr (1+ tr)))
1236                (setq z (cdr z)))
1237              (if cua--debug
1238                  (print (list (current-column) cc) auxbuf))
1239              (just-one-space 0)
1240              (indent-to cc))))
1241       (if (> tr 0)
1242           (message "Warning:  Truncated %d row%s" tr (if (> tr 1) "s" "")))
1243       (if adjust
1244           (cua--rectangle-right (+ (cua--rectangle-left) w -1)))
1245       (if keep
1246           (cua--rectangle-resized)))))
1247
1248 (put 'cua--rectangle-aux-replace 'lisp-indent-function 4)
1249
1250 (defun cua--left-fill-rectangle (_start _end)
1251   (beginning-of-line)
1252   (while (< (point) (point-max))
1253     (delete-horizontal-space nil)
1254     (forward-line 1))
1255   (fill-region-as-paragraph (point-min) (point-max) 'left nil)
1256   (untabify (point-min) (point-max)))
1257
1258 (defun cua-text-fill-rectangle (width text)
1259   "Replace rectangle with filled TEXT read from minibuffer.
1260 A numeric prefix argument is used a new width for the filled rectangle."
1261   (interactive (list
1262                 (prefix-numeric-value current-prefix-arg)
1263                 (read-from-minibuffer "Enter text: "
1264                                       nil nil nil nil)))
1265   (cua--rectangle-aux-replace width t t t 1
1266     'cua--left-fill-rectangle
1267     (lambda () (insert text))))
1268
1269 (defun cua-refill-rectangle (width)
1270   "Fill contents of current rectangle.
1271 A numeric prefix argument is used as new width for the filled rectangle."
1272   (interactive "P")
1273   (cua--rectangle-aux-replace
1274       (if width (prefix-numeric-value width) 0)
1275       t t t 1 'cua--left-fill-rectangle))
1276
1277 (defun cua-shell-command-on-rectangle (replace command)
1278   "Run shell command on rectangle like `shell-command-on-region'.
1279 With prefix arg, replace rectangle with output from command."
1280   (interactive (list
1281                 current-prefix-arg
1282                 (read-from-minibuffer "Shell command on rectangle: "
1283                                       nil nil nil
1284                                       'shell-command-history)))
1285   (cua--rectangle-aux-replace -1 t t replace 1
1286     (lambda (s e)
1287        (shell-command-on-region s e command
1288                                 replace replace nil))))
1289
1290 (defun cua-reverse-rectangle ()
1291   "Reverse the lines of the rectangle."
1292   (interactive)
1293   (cua--rectangle-aux-replace 0 t t t t 'reverse-region))
1294
1295 (defun cua-scroll-rectangle-up ()
1296   "Remove the first line of the rectangle and scroll remaining lines up."
1297   (interactive)
1298   (cua--rectangle-aux-replace 0 t t t t
1299     (lambda (s _e)
1300        (if (= (forward-line 1) 0)
1301            (delete-region s (point))))))
1302
1303 (defun cua-scroll-rectangle-down ()
1304   "Insert a blank line at the first line of the rectangle.
1305 The remaining lines are scrolled down, losing the last line."
1306   (interactive)
1307   (cua--rectangle-aux-replace 0 t t t t
1308     (lambda (s _e)
1309        (goto-char s)
1310        (insert "\n"))))
1311
1312
1313 ;;; Insert/delete text to left or right of rectangle
1314
1315 (defun cua-insert-char-rectangle (&optional ch)
1316   (interactive)
1317   (if buffer-read-only
1318       (ding)
1319     (cua--indent-rectangle (or ch (aref (this-single-command-keys) 0)))
1320     (cua--keep-active))
1321   t)
1322
1323 (defun cua-indent-rectangle (column)
1324   "Indent rectangle to next tab stop.
1325 With prefix arg, indent to that column."
1326   (interactive "P")
1327   (if (null column)
1328       (cua-insert-char-rectangle ?\t)
1329     (cua--indent-rectangle nil (prefix-numeric-value column))))
1330
1331 (defun cua-delete-char-rectangle ()
1332   "Delete char to left or right of rectangle."
1333   (interactive)
1334   (let ((col (cua--rectangle-insert-col))
1335         (pad (cua--rectangle-virtual-edges))
1336         indent)
1337     (cua--rectangle-operation 'corners nil t pad nil
1338      (lambda (_s _e l r)
1339         (move-to-column
1340          (if (cua--rectangle-right-side t)
1341              (max (1+ r) col) l)
1342          pad)
1343         (if (bolp)
1344             nil
1345           (delete-char -1)
1346           (if (cua--rectangle-right-side t)
1347               (cua--rectangle-insert-col (current-column))
1348             (setq indent (- l (current-column))))))
1349      (lambda (l r)
1350         (when (and indent (> indent 0))
1351           (aset cua--rectangle 2 (- l indent))
1352           (aset cua--rectangle 3 (- r indent 1)))))))
1353
1354 (defun cua-help-for-rectangle (&optional help)
1355   (interactive)
1356   (let ((M (cond ((eq cua--rectangle-modifier-key 'hyper) " H-")
1357                  ((eq cua--rectangle-modifier-key 'super) " s-")
1358                  ((eq cua--rectangle-modifier-key 'alt) " A-")
1359                  (t " M-"))))
1360     (message
1361      (concat (if help "C-?:help" "")
1362              M "p:pad" M "o:open" M "c:close" M "b:blank"
1363              M "s:string" M "f:fill" M "i:incr" M "n:seq"))))
1364
1365
1366 ;;; CUA-like cut & paste for rectangles
1367
1368 (defun cua--cancel-rectangle ()
1369   ;; Cancel rectangle
1370   (if cua--rectangle
1371       (cua--deactivate-rectangle))
1372   (setq cua--last-rectangle nil))
1373
1374 (defun cua--rectangle-post-command ()
1375   (if cua--restored-rectangle
1376       (progn
1377         (setq cua--rectangle cua--restored-rectangle
1378               cua--restored-rectangle nil
1379               mark-active t
1380               deactivate-mark nil)
1381         (cua--rectangle-set-corners))
1382     (when (and cua--rectangle cua--buffer-and-point-before-command
1383                (equal (car cua--buffer-and-point-before-command) (current-buffer))
1384                (not (= (cdr cua--buffer-and-point-before-command) (point))))
1385       (if (cua--rectangle-right-side)
1386           (cua--rectangle-right (current-column))
1387         (cua--rectangle-left (current-column)))
1388       (if (>= (cua--rectangle-corner) 2)
1389           (cua--rectangle-bot t)
1390         (cua--rectangle-top t))))
1391   (if cua--rectangle
1392       (if (and mark-active
1393                (not deactivate-mark))
1394           (cua--highlight-rectangle)
1395         (cua--deactivate-rectangle))
1396     (when cua--rectangle-overlays
1397       ;; clean-up after revert-buffer
1398       (mapc (function delete-overlay) cua--rectangle-overlays)
1399       (setq cua--rectangle-overlays nil)
1400       (setq deactivate-mark t)))
1401   (when cua--rect-undo-set-point
1402     (goto-char cua--rect-undo-set-point)
1403     (setq cua--rect-undo-set-point nil)))
1404
1405 ;;; Initialization
1406
1407 (defun cua--rect-M/H-key (key cmd)
1408   (cua--M/H-key cua--rectangle-keymap key cmd))
1409
1410 (defun cua--init-rectangles ()
1411   (define-key cua--rectangle-keymap cua-rectangle-mark-key 'cua-clear-rectangle-mark)
1412   (define-key cua--region-keymap    cua-rectangle-mark-key 'cua-toggle-rectangle-mark)
1413   (unless (eq cua--rectangle-modifier-key 'meta)
1414     (cua--rect-M/H-key ?\s                             'cua-clear-rectangle-mark)
1415     (cua--M/H-key cua--region-keymap ?\s               'cua-toggle-rectangle-mark))
1416
1417   (define-key cua--rectangle-keymap [remap copy-region-as-kill] 'cua-copy-rectangle)
1418   (define-key cua--rectangle-keymap [remap kill-ring-save]      'cua-copy-rectangle)
1419   (define-key cua--rectangle-keymap [remap kill-region]         'cua-cut-rectangle)
1420   (define-key cua--rectangle-keymap [remap delete-char]         'cua-delete-rectangle)
1421   (define-key cua--rectangle-keymap [remap delete-forward-char] 'cua-delete-rectangle)
1422   (define-key cua--rectangle-keymap [remap set-mark-command]    'cua-toggle-rectangle-mark)
1423
1424   (define-key cua--rectangle-keymap [remap forward-char]        'cua-resize-rectangle-right)
1425   (define-key cua--rectangle-keymap [remap right-char]          'cua-resize-rectangle-right)
1426   (define-key cua--rectangle-keymap [remap backward-char]       'cua-resize-rectangle-left)
1427   (define-key cua--rectangle-keymap [remap left-char]           'cua-resize-rectangle-left)
1428   (define-key cua--rectangle-keymap [remap next-line]           'cua-resize-rectangle-down)
1429   (define-key cua--rectangle-keymap [remap previous-line]       'cua-resize-rectangle-up)
1430   (define-key cua--rectangle-keymap [remap end-of-line]         'cua-resize-rectangle-eol)
1431   (define-key cua--rectangle-keymap [remap beginning-of-line]   'cua-resize-rectangle-bol)
1432   (define-key cua--rectangle-keymap [remap end-of-buffer]       'cua-resize-rectangle-bot)
1433   (define-key cua--rectangle-keymap [remap beginning-of-buffer] 'cua-resize-rectangle-top)
1434   (define-key cua--rectangle-keymap [remap scroll-down]         'cua-resize-rectangle-page-up)
1435   (define-key cua--rectangle-keymap [remap scroll-up]           'cua-resize-rectangle-page-down)
1436   (define-key cua--rectangle-keymap [remap scroll-down-command] 'cua-resize-rectangle-page-up)
1437   (define-key cua--rectangle-keymap [remap scroll-up-command]   'cua-resize-rectangle-page-down)
1438
1439   (define-key cua--rectangle-keymap [remap delete-backward-char] 'cua-delete-char-rectangle)
1440   (define-key cua--rectangle-keymap [remap backward-delete-char] 'cua-delete-char-rectangle)
1441   (define-key cua--rectangle-keymap [remap backward-delete-char-untabify] 'cua-delete-char-rectangle)
1442   (define-key cua--rectangle-keymap [remap self-insert-command]  'cua-insert-char-rectangle)
1443   (define-key cua--rectangle-keymap [remap self-insert-iso]      'cua-insert-char-rectangle)
1444
1445   ;; Catch self-inserting characters which are "stolen" by other modes
1446   (define-key cua--rectangle-keymap [t]
1447     '(menu-item "sic" cua-insert-char-rectangle :filter cua--self-insert-char-p))
1448
1449   (define-key cua--rectangle-keymap "\r"     'cua-rotate-rectangle)
1450   (define-key cua--rectangle-keymap "\t"     'cua-indent-rectangle)
1451
1452   (define-key cua--rectangle-keymap [(control ??)] 'cua-help-for-rectangle)
1453
1454   (define-key cua--rectangle-keymap [mouse-1]      'cua-mouse-set-rectangle-mark)
1455   (define-key cua--rectangle-keymap [down-mouse-1] 'cua--mouse-ignore)
1456   (define-key cua--rectangle-keymap [drag-mouse-1] 'cua--mouse-ignore)
1457   (define-key cua--rectangle-keymap [mouse-3]      'cua-mouse-save-then-kill-rectangle)
1458   (define-key cua--rectangle-keymap [down-mouse-3] 'cua--mouse-ignore)
1459   (define-key cua--rectangle-keymap [drag-mouse-3] 'cua--mouse-ignore)
1460
1461   (cua--rect-M/H-key 'up    'cua-move-rectangle-up)
1462   (cua--rect-M/H-key 'down  'cua-move-rectangle-down)
1463   (cua--rect-M/H-key 'left  'cua-move-rectangle-left)
1464   (cua--rect-M/H-key 'right 'cua-move-rectangle-right)
1465
1466   (cua--rect-M/H-key '(control up)   'cua-scroll-rectangle-up)
1467   (cua--rect-M/H-key '(control down) 'cua-scroll-rectangle-down)
1468
1469   (cua--rect-M/H-key ?a 'cua-align-rectangle)
1470   (cua--rect-M/H-key ?b 'cua-blank-rectangle)
1471   (cua--rect-M/H-key ?c 'cua-close-rectangle)
1472   (cua--rect-M/H-key ?f 'cua-fill-char-rectangle)
1473   (cua--rect-M/H-key ?i 'cua-incr-rectangle)
1474   (cua--rect-M/H-key ?k 'cua-cut-rectangle-as-text)
1475   (cua--rect-M/H-key ?l 'cua-downcase-rectangle)
1476   (cua--rect-M/H-key ?m 'cua-copy-rectangle-as-text)
1477   (cua--rect-M/H-key ?n 'cua-sequence-rectangle)
1478   (cua--rect-M/H-key ?o 'cua-open-rectangle)
1479   (cua--rect-M/H-key ?p 'cua-toggle-rectangle-virtual-edges)
1480   (cua--rect-M/H-key ?P 'cua-do-rectangle-padding)
1481   (cua--rect-M/H-key ?q 'cua-refill-rectangle)
1482   (cua--rect-M/H-key ?r 'cua-replace-in-rectangle)
1483   (cua--rect-M/H-key ?R 'cua-reverse-rectangle)
1484   (cua--rect-M/H-key ?s 'cua-string-rectangle)
1485   (cua--rect-M/H-key ?t 'cua-text-fill-rectangle)
1486   (cua--rect-M/H-key ?u 'cua-upcase-rectangle)
1487   (cua--rect-M/H-key ?| 'cua-shell-command-on-rectangle)
1488   (cua--rect-M/H-key ?' 'cua-restrict-prefix-rectangle)
1489   (cua--rect-M/H-key ?/ 'cua-restrict-regexp-rectangle)
1490
1491   (setq cua--rectangle-initialized t))
1492
1493 (provide 'cua-rect)
1494
1495 ;;; cua-rect.el ends here