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