Commit 02033d49 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/rect.el (rectangle-mark-mode): Activate mark even if

transient-mark-mode is off.
(rectangle--highlight-for-redisplay): Fix boundary condition when point
is > mark and at bolp.

Fixes: debbugs:16066
parent 6407822c
...@@ -7,6 +7,11 @@ ...@@ -7,6 +7,11 @@
2013-12-08 Stefan Monnier <monnier@iro.umontreal.ca> 2013-12-08 Stefan Monnier <monnier@iro.umontreal.ca>
* rect.el (rectangle-mark-mode): Activate mark even if
transient-mark-mode is off (bug#16066).
(rectangle--highlight-for-redisplay): Fix boundary condition when point
is > mark and at bolp.
* emulation/cua-rect.el (cua--rectangle-region-extract): New function. * emulation/cua-rect.el (cua--rectangle-region-extract): New function.
(region-extract-function): Use it. (region-extract-function): Use it.
(cua-mouse-save-then-kill-rectangle): Use cua-copy-region. (cua-mouse-save-then-kill-rectangle): Use cua-copy-region.
......
...@@ -443,7 +443,9 @@ with a prefix argument, prompt for START-AT and FORMAT." ...@@ -443,7 +443,9 @@ with a prefix argument, prompt for START-AT and FORMAT."
Activates the region if needed. Only lasts until the region is deactivated." Activates the region if needed. Only lasts until the region is deactivated."
nil nil nil nil nil nil
(when rectangle-mark-mode (when rectangle-mark-mode
(unless (region-active-p) (push-mark-command t)))) (unless (region-active-p)
(push-mark)
(activate-mark))))
(defun rectangle--extract-region (orig &optional delete) (defun rectangle--extract-region (orig &optional delete)
(if (not rectangle-mark-mode) (if (not rectangle-mark-mode)
...@@ -495,70 +497,72 @@ Activates the region if needed. Only lasts until the region is deactivated." ...@@ -495,70 +497,72 @@ Activates the region if needed. Only lasts until the region is deactivated."
(leftcol (min ptcol markcol)) (leftcol (min ptcol markcol))
(rightcol (max ptcol markcol))) (rightcol (max ptcol markcol)))
(goto-char start) (goto-char start)
(while (< (point) end) (while
(let* ((mleft (move-to-column leftcol)) (let* ((mleft (move-to-column leftcol))
(left (point)) (left (point))
(mright (move-to-column rightcol)) (mright (move-to-column rightcol))
(right (point)) (right (point))
(ol (ol
(if (not old) (if (not old)
(let ((ol (make-overlay left right))) (let ((ol (make-overlay left right)))
(overlay-put ol 'window window) (overlay-put ol 'window window)
(overlay-put ol 'face 'region) (overlay-put ol 'face 'region)
ol) ol)
(let ((ol (pop old))) (let ((ol (pop old)))
(move-overlay ol left right (current-buffer)) (move-overlay ol left right (current-buffer))
ol)))) ol))))
;; `move-to-column' may stop before the column (if bumping into ;; `move-to-column' may stop before the column (if bumping into
;; EOL) or overshoot it a little, when column is in the middle ;; EOL) or overshoot it a little, when column is in the middle
;; of a char. ;; of a char.
(cond (cond
((< mleft leftcol) ;`leftcol' is past EOL. ((< mleft leftcol) ;`leftcol' is past EOL.
(overlay-put ol 'before-string (overlay-put ol 'before-string
(spaces-string (- leftcol mleft))) (spaces-string (- leftcol mleft)))
(setq mright (max mright leftcol))) (setq mright (max mright leftcol)))
((and (> mleft leftcol) ;`leftcol' is in the middle of a char. ((and (> mleft leftcol) ;`leftcol' is in the middle of a char.
(eq (char-before left) ?\t)) (eq (char-before left) ?\t))
(setq left (1- left)) (setq left (1- left))
(move-overlay ol left right) (move-overlay ol left right)
(goto-char left) (goto-char left)
(overlay-put ol 'before-string (overlay-put ol 'before-string
(spaces-string (- leftcol (current-column))))) (spaces-string (- leftcol (current-column)))))
((overlay-get ol 'before-string) ((overlay-get ol 'before-string)
(overlay-put ol 'before-string nil))) (overlay-put ol 'before-string nil)))
(cond (cond
((< mright rightcol) ;`rightcol' is past EOL. ((< mright rightcol) ;`rightcol' is past EOL.
(let ((str (make-string (- rightcol mright) ?\s))) (let ((str (make-string (- rightcol mright) ?\s)))
(put-text-property 0 (length str) 'face 'region str) (put-text-property 0 (length str) 'face 'region str)
;; If cursor happens to be here, draw it *before* rather than ;; If cursor happens to be here, draw it *before* rather than
;; after this highlighted pseudo-text. ;; after this highlighted pseudo-text.
(put-text-property 0 1 'cursor t str) (put-text-property 0 1 'cursor t str)
(overlay-put ol 'after-string str))) (overlay-put ol 'after-string str)))
((and (> mright rightcol) ;`rightcol' is in the middle of a char. ((and (> mright rightcol) ;`rightcol's in the middle of a char.
(eq (char-before right) ?\t)) (eq (char-before right) ?\t))
(setq right (1- right)) (setq right (1- right))
(move-overlay ol left right) (move-overlay ol left right)
(if (= rightcol leftcol) (if (= rightcol leftcol)
(overlay-put ol 'after-string nil) (overlay-put ol 'after-string nil)
(goto-char right) (goto-char right)
(let ((str (make-string (let ((str (make-string
(- rightcol (max leftcol (current-column))) ?\s))) (- rightcol (max leftcol (current-column)))
(put-text-property 0 (length str) 'face 'region str) ?\s)))
(when (= left right) (put-text-property 0 (length str) 'face 'region str)
;; If cursor happens to be here, draw it *before* rather (when (= left right)
;; than after this highlighted pseudo-text. ;; If cursor happens to be here, draw it *before* rather
(put-text-property 0 1 'cursor 1 str)) ;; than after this highlighted pseudo-text.
(overlay-put ol 'after-string str)))) (put-text-property 0 1 'cursor 1 str))
((overlay-get ol 'after-string) (overlay-put ol 'after-string str))))
(overlay-put ol 'after-string nil))) ((overlay-get ol 'after-string)
(when (= leftcol rightcol) (overlay-put ol 'after-string nil)))
;; Make zero-width rectangles visible! (when (= leftcol rightcol)
(overlay-put ol 'after-string ;; Make zero-width rectangles visible!
(concat (propertize " " (overlay-put ol 'after-string
'face '(region (:height 0.2))) (concat (propertize " "
(overlay-get ol 'after-string)))) 'face '(region (:height 0.2)))
(push ol nrol)) (overlay-get ol 'after-string))))
(forward-line 1)) (push ol nrol)
(and (zerop (forward-line 1))
(<= (point) end))))
(mapc #'delete-overlay old) (mapc #'delete-overlay old)
`(rectangle ,(buffer-chars-modified-tick) ,start ,end ,@nrol)))))) `(rectangle ,(buffer-chars-modified-tick) ,start ,end ,@nrol))))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment