| 1 | ;;; rect.el --- rectangle functions for GNU Emacs -*- lexical-binding:t -*- |
| 2 | |
| 3 | ;; Copyright (C) 1985, 1999-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Maintainer: Didier Verna <didier@xemacs.org> |
| 6 | ;; Keywords: internal |
| 7 | ;; Package: emacs |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; This package provides the operations on rectangles that are documented |
| 27 | ;; in the Emacs manual. |
| 28 | |
| 29 | ;; ### NOTE: this file was almost completely rewritten by Didier Verna |
| 30 | ;; <didier@xemacs.org> in July 1999. |
| 31 | |
| 32 | ;;; Code: |
| 33 | |
| 34 | ;; FIXME: this function should be replaced by `apply-on-rectangle' |
| 35 | (defun operate-on-rectangle (function start end coerce-tabs) |
| 36 | "Call FUNCTION for each line of rectangle with corners at START, END. |
| 37 | If COERCE-TABS is non-nil, convert multi-column characters |
| 38 | that span the starting or ending columns on any line |
| 39 | to multiple spaces before calling FUNCTION. |
| 40 | FUNCTION is called with three arguments: |
| 41 | position of start of segment of this line within the rectangle, |
| 42 | number of columns that belong to rectangle but are before that position, |
| 43 | number of columns that belong to rectangle but are after point. |
| 44 | Point is at the end of the segment of this line within the rectangle." |
| 45 | (let (startcol startlinepos endcol endlinepos) |
| 46 | (save-excursion |
| 47 | (goto-char start) |
| 48 | (setq startcol (current-column)) |
| 49 | (beginning-of-line) |
| 50 | (setq startlinepos (point))) |
| 51 | (save-excursion |
| 52 | (goto-char end) |
| 53 | (setq endcol (current-column)) |
| 54 | (forward-line 1) |
| 55 | (setq endlinepos (point-marker))) |
| 56 | (if (< endcol startcol) |
| 57 | (setq startcol (prog1 endcol (setq endcol startcol)))) |
| 58 | (save-excursion |
| 59 | (goto-char startlinepos) |
| 60 | (while (< (point) endlinepos) |
| 61 | (let (startpos begextra endextra) |
| 62 | (if coerce-tabs |
| 63 | (move-to-column startcol t) |
| 64 | (move-to-column startcol)) |
| 65 | (setq begextra (- (current-column) startcol)) |
| 66 | (setq startpos (point)) |
| 67 | (if coerce-tabs |
| 68 | (move-to-column endcol t) |
| 69 | (move-to-column endcol)) |
| 70 | ;; If we overshot, move back one character |
| 71 | ;; so that endextra will be positive. |
| 72 | (if (and (not coerce-tabs) (> (current-column) endcol)) |
| 73 | (backward-char 1)) |
| 74 | (setq endextra (- endcol (current-column))) |
| 75 | (if (< begextra 0) |
| 76 | (setq endextra (+ endextra begextra) |
| 77 | begextra 0)) |
| 78 | (funcall function startpos begextra endextra)) |
| 79 | (forward-line 1))) |
| 80 | (- endcol startcol))) |
| 81 | |
| 82 | (defun apply-on-rectangle (function start end &rest args) |
| 83 | "Call FUNCTION for each line of rectangle with corners at START, END. |
| 84 | FUNCTION is called with two arguments: the start and end columns of the |
| 85 | rectangle, plus ARGS extra arguments. Point is at the beginning of line when |
| 86 | the function is called. |
| 87 | The final point after the last operation will be returned." |
| 88 | (let (startcol startpt endcol endpt final-point) |
| 89 | (save-excursion |
| 90 | (goto-char start) |
| 91 | (setq startcol (current-column)) |
| 92 | (beginning-of-line) |
| 93 | (setq startpt (point)) |
| 94 | (goto-char end) |
| 95 | (setq endcol (current-column)) |
| 96 | (forward-line 1) |
| 97 | (setq endpt (point-marker)) |
| 98 | ;; ensure the start column is the left one. |
| 99 | (if (< endcol startcol) |
| 100 | (let ((col startcol)) |
| 101 | (setq startcol endcol endcol col))) |
| 102 | ;; start looping over lines |
| 103 | (goto-char startpt) |
| 104 | (while (< (point) endpt) |
| 105 | (apply function startcol endcol args) |
| 106 | (setq final-point (point)) |
| 107 | (forward-line 1))) |
| 108 | final-point)) |
| 109 | |
| 110 | (defun delete-rectangle-line (startcol endcol fill) |
| 111 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
| 112 | (delete-region (point) |
| 113 | (progn (move-to-column endcol 'coerce) |
| 114 | (point))))) |
| 115 | |
| 116 | (defun delete-extract-rectangle-line (startcol endcol lines fill) |
| 117 | (let ((pt (point-at-eol))) |
| 118 | (if (< (move-to-column startcol (if fill t 'coerce)) startcol) |
| 119 | (setcdr lines (cons (spaces-string (- endcol startcol)) |
| 120 | (cdr lines))) |
| 121 | ;; else |
| 122 | (setq pt (point)) |
| 123 | (move-to-column endcol t) |
| 124 | (setcdr lines (cons (filter-buffer-substring pt (point) t) (cdr lines)))) |
| 125 | )) |
| 126 | |
| 127 | ;; This is actually the only function that needs to do complicated |
| 128 | ;; stuff like what's happening in `operate-on-rectangle', because the |
| 129 | ;; buffer might be read-only. |
| 130 | (defun extract-rectangle-line (startcol endcol lines) |
| 131 | (let (start end begextra endextra line) |
| 132 | (move-to-column startcol) |
| 133 | (setq start (point) |
| 134 | begextra (- (current-column) startcol)) |
| 135 | (move-to-column endcol) |
| 136 | (setq end (point) |
| 137 | endextra (- endcol (current-column))) |
| 138 | (setq line (buffer-substring start (point))) |
| 139 | (if (< begextra 0) |
| 140 | (setq endextra (+ endextra begextra) |
| 141 | begextra 0)) |
| 142 | (if (< endextra 0) |
| 143 | (setq endextra 0)) |
| 144 | (goto-char start) |
| 145 | (while (search-forward "\t" end t) |
| 146 | (let ((width (- (current-column) |
| 147 | (save-excursion (forward-char -1) |
| 148 | (current-column))))) |
| 149 | (setq line (concat (substring line 0 (- (point) end 1)) |
| 150 | (spaces-string width) |
| 151 | (substring line (+ (length line) |
| 152 | (- (point) end))))))) |
| 153 | (if (or (> begextra 0) (> endextra 0)) |
| 154 | (setq line (concat (spaces-string begextra) |
| 155 | line |
| 156 | (spaces-string endextra)))) |
| 157 | (setcdr lines (cons line (cdr lines))))) |
| 158 | |
| 159 | (defconst spaces-strings |
| 160 | '["" " " " " " " " " " " " " " " " "]) |
| 161 | |
| 162 | (defun spaces-string (n) |
| 163 | "Return a string with N spaces." |
| 164 | (if (<= n 8) (aref spaces-strings n) |
| 165 | (make-string n ?\s))) |
| 166 | |
| 167 | ;;;###autoload |
| 168 | (defun delete-rectangle (start end &optional fill) |
| 169 | "Delete (don't save) text in the region-rectangle. |
| 170 | The same range of columns is deleted in each line starting with the |
| 171 | line where the region begins and ending with the line where the region |
| 172 | ends. |
| 173 | |
| 174 | When called from a program the rectangle's corners are START and END. |
| 175 | With a prefix (or a FILL) argument, also fill lines where nothing has |
| 176 | to be deleted." |
| 177 | (interactive "*r\nP") |
| 178 | (apply-on-rectangle 'delete-rectangle-line start end fill)) |
| 179 | |
| 180 | ;;;###autoload |
| 181 | (defun delete-extract-rectangle (start end &optional fill) |
| 182 | "Delete the contents of the rectangle with corners at START and END. |
| 183 | Return it as a list of strings, one for each line of the rectangle. |
| 184 | |
| 185 | When called from a program the rectangle's corners are START and END. |
| 186 | With an optional FILL argument, also fill lines where nothing has to be |
| 187 | deleted." |
| 188 | (let ((lines (list nil))) |
| 189 | (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill) |
| 190 | (nreverse (cdr lines)))) |
| 191 | |
| 192 | ;;;###autoload |
| 193 | (defun extract-rectangle (start end) |
| 194 | "Return the contents of the rectangle with corners at START and END. |
| 195 | Return it as a list of strings, one for each line of the rectangle." |
| 196 | (let ((lines (list nil))) |
| 197 | (apply-on-rectangle 'extract-rectangle-line start end lines) |
| 198 | (nreverse (cdr lines)))) |
| 199 | |
| 200 | (defvar killed-rectangle nil |
| 201 | "Rectangle for `yank-rectangle' to insert.") |
| 202 | |
| 203 | ;;;###autoload |
| 204 | (defun kill-rectangle (start end &optional fill) |
| 205 | "Delete the region-rectangle and save it as the last killed one. |
| 206 | |
| 207 | When called from a program the rectangle's corners are START and END. |
| 208 | You might prefer to use `delete-extract-rectangle' from a program. |
| 209 | |
| 210 | With a prefix (or a FILL) argument, also fill lines where nothing has to be |
| 211 | deleted. |
| 212 | |
| 213 | If the buffer is read-only, Emacs will beep and refrain from deleting |
| 214 | the rectangle, but put it in the kill ring anyway. This means that |
| 215 | you can use this command to copy text from a read-only buffer. |
| 216 | \(If the variable `kill-read-only-ok' is non-nil, then this won't |
| 217 | even beep.)" |
| 218 | (interactive "r\nP") |
| 219 | (condition-case nil |
| 220 | (setq killed-rectangle (delete-extract-rectangle start end fill)) |
| 221 | ((buffer-read-only text-read-only) |
| 222 | (setq deactivate-mark t) |
| 223 | (setq killed-rectangle (extract-rectangle start end)) |
| 224 | (if kill-read-only-ok |
| 225 | (progn (message "Read only text copied to kill ring") nil) |
| 226 | (barf-if-buffer-read-only) |
| 227 | (signal 'text-read-only (list (current-buffer))))))) |
| 228 | |
| 229 | ;;;###autoload |
| 230 | (defun copy-rectangle-as-kill (start end) |
| 231 | "Copy the region-rectangle and save it as the last killed one." |
| 232 | (interactive "r") |
| 233 | (setq killed-rectangle (extract-rectangle start end)) |
| 234 | (setq deactivate-mark t) |
| 235 | (if (called-interactively-p 'interactive) |
| 236 | (indicate-copied-region (length (car killed-rectangle))))) |
| 237 | |
| 238 | ;;;###autoload |
| 239 | (defun yank-rectangle () |
| 240 | "Yank the last killed rectangle with upper left corner at point." |
| 241 | (interactive "*") |
| 242 | (insert-rectangle killed-rectangle)) |
| 243 | |
| 244 | ;;;###autoload |
| 245 | (defun insert-rectangle (rectangle) |
| 246 | "Insert text of RECTANGLE with upper left corner at point. |
| 247 | RECTANGLE's first line is inserted at point, its second |
| 248 | line is inserted at a point vertically under point, etc. |
| 249 | RECTANGLE should be a list of strings. |
| 250 | After this command, the mark is at the upper left corner |
| 251 | and point is at the lower right corner." |
| 252 | (let ((lines rectangle) |
| 253 | (insertcolumn (current-column)) |
| 254 | (first t)) |
| 255 | (push-mark) |
| 256 | (while lines |
| 257 | (or first |
| 258 | (progn |
| 259 | (forward-line 1) |
| 260 | (or (bolp) (insert ?\n)) |
| 261 | (move-to-column insertcolumn t))) |
| 262 | (setq first nil) |
| 263 | (insert-for-yank (car lines)) |
| 264 | (setq lines (cdr lines))))) |
| 265 | |
| 266 | ;;;###autoload |
| 267 | (defun open-rectangle (start end &optional fill) |
| 268 | "Blank out the region-rectangle, shifting text right. |
| 269 | |
| 270 | The text previously in the region is not overwritten by the blanks, |
| 271 | but instead winds up to the right of the rectangle. |
| 272 | |
| 273 | When called from a program the rectangle's corners are START and END. |
| 274 | With a prefix (or a FILL) argument, fill with blanks even if there is |
| 275 | no text on the right side of the rectangle." |
| 276 | (interactive "*r\nP") |
| 277 | (apply-on-rectangle 'open-rectangle-line start end fill) |
| 278 | (goto-char start)) |
| 279 | |
| 280 | (defun open-rectangle-line (startcol endcol fill) |
| 281 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
| 282 | (unless (and (not fill) |
| 283 | (= (point) (point-at-eol))) |
| 284 | (indent-to endcol)))) |
| 285 | |
| 286 | (defun delete-whitespace-rectangle-line (startcol _endcol fill) |
| 287 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
| 288 | (unless (= (point) (point-at-eol)) |
| 289 | (delete-region (point) (progn (skip-syntax-forward " ") (point)))))) |
| 290 | |
| 291 | ;;;###autoload |
| 292 | (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name |
| 293 | |
| 294 | ;;;###autoload |
| 295 | (defun delete-whitespace-rectangle (start end &optional fill) |
| 296 | "Delete all whitespace following a specified column in each line. |
| 297 | The left edge of the rectangle specifies the position in each line |
| 298 | at which whitespace deletion should begin. On each line in the |
| 299 | rectangle, all continuous whitespace starting at that column is deleted. |
| 300 | |
| 301 | When called from a program the rectangle's corners are START and END. |
| 302 | With a prefix (or a FILL) argument, also fill too short lines." |
| 303 | (interactive "*r\nP") |
| 304 | (apply-on-rectangle 'delete-whitespace-rectangle-line start end fill)) |
| 305 | |
| 306 | (defvar string-rectangle-history nil) |
| 307 | (defun string-rectangle-line (startcol endcol string delete) |
| 308 | (move-to-column startcol t) |
| 309 | (if delete |
| 310 | (delete-rectangle-line startcol endcol nil)) |
| 311 | (insert string)) |
| 312 | |
| 313 | ;;;###autoload |
| 314 | (defun string-rectangle (start end string) |
| 315 | "Replace rectangle contents with STRING on each line. |
| 316 | The length of STRING need not be the same as the rectangle width. |
| 317 | |
| 318 | Called from a program, takes three args; START, END and STRING." |
| 319 | (interactive |
| 320 | (progn (barf-if-buffer-read-only) |
| 321 | (list |
| 322 | (region-beginning) |
| 323 | (region-end) |
| 324 | (read-string (format "String rectangle (default %s): " |
| 325 | (or (car string-rectangle-history) "")) |
| 326 | nil 'string-rectangle-history |
| 327 | (car string-rectangle-history))))) |
| 328 | (goto-char |
| 329 | (apply-on-rectangle 'string-rectangle-line start end string t))) |
| 330 | |
| 331 | ;;;###autoload |
| 332 | (defalias 'replace-rectangle 'string-rectangle) |
| 333 | |
| 334 | ;;;###autoload |
| 335 | (defun string-insert-rectangle (start end string) |
| 336 | "Insert STRING on each line of region-rectangle, shifting text right. |
| 337 | |
| 338 | When called from a program, the rectangle's corners are START and END. |
| 339 | The left edge of the rectangle specifies the column for insertion. |
| 340 | This command does not delete or overwrite any existing text." |
| 341 | (interactive |
| 342 | (progn (barf-if-buffer-read-only) |
| 343 | (list |
| 344 | (region-beginning) |
| 345 | (region-end) |
| 346 | (read-string (format "String insert rectangle (default %s): " |
| 347 | (or (car string-rectangle-history) "")) |
| 348 | nil 'string-rectangle-history |
| 349 | (car string-rectangle-history))))) |
| 350 | (apply-on-rectangle 'string-rectangle-line start end string nil)) |
| 351 | |
| 352 | ;;;###autoload |
| 353 | (defun clear-rectangle (start end &optional fill) |
| 354 | "Blank out the region-rectangle. |
| 355 | The text previously in the region is overwritten with blanks. |
| 356 | |
| 357 | When called from a program the rectangle's corners are START and END. |
| 358 | With a prefix (or a FILL) argument, also fill with blanks the parts of the |
| 359 | rectangle which were empty." |
| 360 | (interactive "*r\nP") |
| 361 | (apply-on-rectangle 'clear-rectangle-line start end fill)) |
| 362 | |
| 363 | (defun clear-rectangle-line (startcol endcol fill) |
| 364 | (let ((pt (point-at-eol))) |
| 365 | (when (= (move-to-column startcol (if fill t 'coerce)) startcol) |
| 366 | (if (and (not fill) |
| 367 | (<= (save-excursion (goto-char pt) (current-column)) endcol)) |
| 368 | (delete-region (point) pt) |
| 369 | ;; else |
| 370 | (setq pt (point)) |
| 371 | (move-to-column endcol t) |
| 372 | (setq endcol (current-column)) |
| 373 | (delete-region pt (point)) |
| 374 | (indent-to endcol))))) |
| 375 | |
| 376 | ;; Line numbers for `rectangle-number-line-callback'. |
| 377 | (defvar rectangle-number-line-counter) |
| 378 | |
| 379 | (defun rectangle-number-line-callback (start _end format-string) |
| 380 | (move-to-column start t) |
| 381 | (insert (format format-string rectangle-number-line-counter)) |
| 382 | (setq rectangle-number-line-counter |
| 383 | (1+ rectangle-number-line-counter))) |
| 384 | |
| 385 | (defun rectange--default-line-number-format (start end start-at) |
| 386 | (concat "%" |
| 387 | (int-to-string (length (int-to-string (+ (count-lines start end) |
| 388 | start-at)))) |
| 389 | "d ")) |
| 390 | |
| 391 | ;;;###autoload |
| 392 | (defun rectangle-number-lines (start end start-at &optional format) |
| 393 | "Insert numbers in front of the region-rectangle. |
| 394 | |
| 395 | START-AT, if non-nil, should be a number from which to begin |
| 396 | counting. FORMAT, if non-nil, should be a format string to pass |
| 397 | to `format' along with the line count. When called interactively |
| 398 | with a prefix argument, prompt for START-AT and FORMAT." |
| 399 | (interactive |
| 400 | (if current-prefix-arg |
| 401 | (let* ((start (region-beginning)) |
| 402 | (end (region-end)) |
| 403 | (start-at (read-number "Number to count from: " 1))) |
| 404 | (list start end start-at |
| 405 | (read-string "Format string: " |
| 406 | (rectange--default-line-number-format |
| 407 | start end start-at)))) |
| 408 | (list (region-beginning) (region-end) 1 nil))) |
| 409 | (unless format |
| 410 | (setq format (rectange--default-line-number-format start end start-at))) |
| 411 | (let ((rectangle-number-line-counter start-at)) |
| 412 | (apply-on-rectangle 'rectangle-number-line-callback |
| 413 | start end format))) |
| 414 | |
| 415 | ;;; New rectangle integration with kill-ring. |
| 416 | |
| 417 | ;; FIXME: known problems with the new rectangle support: |
| 418 | ;; - lots of commands handle the region without paying attention to its |
| 419 | ;; rectangular shape. |
| 420 | |
| 421 | (add-function :around redisplay-highlight-region-function |
| 422 | #'rectangle--highlight-for-redisplay) |
| 423 | (add-function :around redisplay-unhighlight-region-function |
| 424 | #'rectangle--unhighlight-for-redisplay) |
| 425 | (add-function :around region-extract-function |
| 426 | #'rectangle--extract-region) |
| 427 | |
| 428 | (defvar rectangle-mark-mode-map |
| 429 | (let ((map (make-sparse-keymap))) |
| 430 | (define-key map [?\C-o] 'open-rectangle) |
| 431 | (define-key map [?\C-t] 'string-rectangle) |
| 432 | ;; (define-key map [remap open-line] 'open-rectangle) |
| 433 | ;; (define-key map [remap transpose-chars] 'string-rectangle) |
| 434 | map) |
| 435 | "Keymap used while marking a rectangular region.") |
| 436 | |
| 437 | ;;;###autoload |
| 438 | (define-minor-mode rectangle-mark-mode |
| 439 | "Toggle the region as rectangular. |
| 440 | Activates the region if needed. Only lasts until the region is deactivated." |
| 441 | nil nil nil |
| 442 | (when rectangle-mark-mode |
| 443 | (add-hook 'deactivate-mark-hook |
| 444 | (lambda () (rectangle-mark-mode -1))) |
| 445 | (unless (region-active-p) |
| 446 | (push-mark) |
| 447 | (activate-mark) |
| 448 | (message "Mark set (rectangle mode)")))) |
| 449 | |
| 450 | (defun rectangle--extract-region (orig &optional delete) |
| 451 | (if (not rectangle-mark-mode) |
| 452 | (funcall orig delete) |
| 453 | (let* ((strs (funcall (if delete |
| 454 | #'delete-extract-rectangle |
| 455 | #'extract-rectangle) |
| 456 | (region-beginning) (region-end))) |
| 457 | (str (mapconcat #'identity strs "\n"))) |
| 458 | (when (eq last-command 'kill-region) |
| 459 | ;; Try to prevent kill-region from appending this to some |
| 460 | ;; earlier element. |
| 461 | (setq last-command 'kill-region-dont-append)) |
| 462 | (when strs |
| 463 | (put-text-property 0 (length str) 'yank-handler |
| 464 | `(rectangle--insert-for-yank ,strs t) |
| 465 | str) |
| 466 | str)))) |
| 467 | |
| 468 | (defun rectangle--insert-for-yank (strs) |
| 469 | (push (point) buffer-undo-list) |
| 470 | (let ((undo-at-start buffer-undo-list)) |
| 471 | (insert-rectangle strs) |
| 472 | (setq yank-undo-function |
| 473 | (lambda (_start _end) |
| 474 | (undo-start) |
| 475 | (setcar undo-at-start nil) ;Turn it into a boundary. |
| 476 | (while (not (eq pending-undo-list (cdr undo-at-start))) |
| 477 | (undo-more 1)))))) |
| 478 | |
| 479 | (defun rectangle--highlight-for-redisplay (orig start end window rol) |
| 480 | (cond |
| 481 | ((not rectangle-mark-mode) |
| 482 | (funcall orig start end window rol)) |
| 483 | ((and (eq 'rectangle (car-safe rol)) |
| 484 | (eq (nth 1 rol) (buffer-chars-modified-tick)) |
| 485 | (eq start (nth 2 rol)) |
| 486 | (eq end (nth 3 rol))) |
| 487 | rol) |
| 488 | (t |
| 489 | (save-excursion |
| 490 | (let* ((nrol nil) |
| 491 | (old (if (eq 'rectangle (car-safe rol)) |
| 492 | (nthcdr 4 rol) |
| 493 | (funcall redisplay-unhighlight-region-function rol) |
| 494 | nil)) |
| 495 | (ptcol (progn (goto-char start) (current-column))) |
| 496 | (markcol (progn (goto-char end) (current-column))) |
| 497 | (leftcol (min ptcol markcol)) |
| 498 | (rightcol (max ptcol markcol))) |
| 499 | (goto-char start) |
| 500 | (while |
| 501 | (let* ((mleft (move-to-column leftcol)) |
| 502 | (left (point)) |
| 503 | (mright (move-to-column rightcol)) |
| 504 | (right (point)) |
| 505 | (ol |
| 506 | (if (not old) |
| 507 | (let ((ol (make-overlay left right))) |
| 508 | (overlay-put ol 'window window) |
| 509 | (overlay-put ol 'face 'region) |
| 510 | ol) |
| 511 | (let ((ol (pop old))) |
| 512 | (move-overlay ol left right (current-buffer)) |
| 513 | ol)))) |
| 514 | ;; `move-to-column' may stop before the column (if bumping into |
| 515 | ;; EOL) or overshoot it a little, when column is in the middle |
| 516 | ;; of a char. |
| 517 | (cond |
| 518 | ((< mleft leftcol) ;`leftcol' is past EOL. |
| 519 | (overlay-put ol 'before-string |
| 520 | (spaces-string (- leftcol mleft))) |
| 521 | (setq mright (max mright leftcol))) |
| 522 | ((and (> mleft leftcol) ;`leftcol' is in the middle of a char. |
| 523 | (eq (char-before left) ?\t)) |
| 524 | (setq left (1- left)) |
| 525 | (move-overlay ol left right) |
| 526 | (goto-char left) |
| 527 | (overlay-put ol 'before-string |
| 528 | (spaces-string (- leftcol (current-column))))) |
| 529 | ((overlay-get ol 'before-string) |
| 530 | (overlay-put ol 'before-string nil))) |
| 531 | (cond |
| 532 | ((< mright rightcol) ;`rightcol' is past EOL. |
| 533 | (let ((str (make-string (- rightcol mright) ?\s))) |
| 534 | (put-text-property 0 (length str) 'face 'region str) |
| 535 | ;; If cursor happens to be here, draw it *before* rather than |
| 536 | ;; after this highlighted pseudo-text. |
| 537 | (put-text-property 0 1 'cursor t str) |
| 538 | (overlay-put ol 'after-string str))) |
| 539 | ((and (> mright rightcol) ;`rightcol's in the middle of a char. |
| 540 | (eq (char-before right) ?\t)) |
| 541 | (setq right (1- right)) |
| 542 | (move-overlay ol left right) |
| 543 | (if (= rightcol leftcol) |
| 544 | (overlay-put ol 'after-string nil) |
| 545 | (goto-char right) |
| 546 | (let ((str (make-string |
| 547 | (- rightcol (max leftcol (current-column))) |
| 548 | ?\s))) |
| 549 | (put-text-property 0 (length str) 'face 'region str) |
| 550 | (when (= left right) |
| 551 | ;; If cursor happens to be here, draw it *before* rather |
| 552 | ;; than after this highlighted pseudo-text. |
| 553 | (put-text-property 0 1 'cursor 1 str)) |
| 554 | (overlay-put ol 'after-string str)))) |
| 555 | ((overlay-get ol 'after-string) |
| 556 | (overlay-put ol 'after-string nil))) |
| 557 | (when (and (= leftcol rightcol) (display-graphic-p)) |
| 558 | ;; Make zero-width rectangles visible! |
| 559 | (overlay-put ol 'after-string |
| 560 | (concat (propertize " " |
| 561 | 'face '(region (:height 0.2))) |
| 562 | (overlay-get ol 'after-string)))) |
| 563 | (push ol nrol) |
| 564 | (and (zerop (forward-line 1)) |
| 565 | (<= (point) end)))) |
| 566 | (mapc #'delete-overlay old) |
| 567 | `(rectangle ,(buffer-chars-modified-tick) ,start ,end ,@nrol)))))) |
| 568 | |
| 569 | (defun rectangle--unhighlight-for-redisplay (orig rol) |
| 570 | (if (not (eq 'rectangle (car-safe rol))) |
| 571 | (funcall orig rol) |
| 572 | (mapc #'delete-overlay (nthcdr 4 rol)) |
| 573 | (setcar (cdr rol) nil))) |
| 574 | |
| 575 | (provide 'rect) |
| 576 | |
| 577 | ;;; rect.el ends here |