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